home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
QRZ! Ham Radio 8
/
QRZ Ham Radio Callsign Database - Volume 8.iso
/
pc
/
files
/
ant_nec
/
nec_in_c.tz
/
nec_in_c
/
NEC2
/
nec2.c
< prev
next >
Wrap
C/C++ Source or Header
|
1992-02-29
|
826KB
|
28,350 lines
/* n.f -- translated by f2c (version of 17 January 1992 0:17:58).
You must link the resulting object file with the libraries:
-lF77 -lI77 -lm -lc (in that order)
*/
#include "f2c.h"
/* Common Block Declarations */
struct {
doublecomplex cm[90000];
} cmb_;
#define cmb_1 cmb_
struct {
doublereal x[600], y[600], z[600], si[600], bi[600], alp[600], bet[600],
wlam;
integer icon1[800], icon2[800], itag[800], iconx[600], ipsym, ld, n1, n2,
n, np, m1, m2, m, mp;
} data_;
#define data_1 data_
struct {
integer icase, nbloks, npblk, nlast, nblsym, npsym, nlsym, imat, icasx,
nbbx, npbx, nlbx, nbbl, npbl, nlbl;
} matpar_;
#define matpar_1 matpar_
struct {
doublereal com[95] /* was [19][5] */, epsr, sig, scrwlt, scrwrt, fmhz;
integer ip[800], kcom;
} save_;
#define save_1 save_
struct {
doublereal air[600], aii[600], bir[600], bii[600], cir[600], cii[600];
doublecomplex cur[1000];
} crnt_;
#define crnt_1 crnt_
struct {
doublecomplex zrati, zrati2, frati;
doublereal cl, ch, scrwl, scrwr;
integer nradl, ksymp, ifar, iperf;
doublecomplex t1;
doublereal t2;
} gnd_;
#define gnd_1 gnd_
struct {
doublecomplex zarray[600];
integer nload, nlodf;
} zload_;
#define zload_1 zload_
struct {
integer ncoup, icoup, nctag[5], ncseg[5];
doublecomplex y11a[5], y12a[20];
} yparm_;
#define yparm_1 yparm_
struct {
doublereal ax[30], bx[30], cx[30];
integer jco[30], jsno, iscon[50], nscon, ipcon[10], npcon;
} segj_;
#define segj_1 segj_
struct {
doublecomplex vqd[30], vsant[30], vqds[30];
integer ivqd[30], isant[30], iqds[30], nvqd, nsant, nqds;
} vsorc_;
#define vsorc_1 vsorc_
struct {
doublecomplex zped;
doublereal pin, pnls, x11r[150], x11i[150], x12r[150], x12i[150], x22r[
150], x22i[150];
integer ntyp[150], neq, npeq, neq2, nonet, ntsol, nprint, masym, iseg1[
150], iseg2[150];
} netcx_;
#define netcx_1 netcx_
struct {
doublereal thets, phis, dth, dph, rfld, gnor, clt, cht, epsr2, sig2, xpr6,
pinr, pnlr, ploss, xnr, ynr, znr, dxnr, dynr, dznr;
integer nth, nph, ipd, iavp, inor, iax, ixtyp, near, nfeh, nrx, nry, nrz;
} fpat_;
#define fpat_1 fpat_
struct {
doublecomplex ar1[440] /* was [11][10][4] */, ar2[340] /* was [17][5]
[4] */, ar3[288] /* was [9][8][4] */, epscf;
doublereal dxa[3], dya[3], xsa[3], ysa[3];
integer nxa[3], nya[3];
} ggrid_;
#define ggrid_1 ggrid_
struct {
doublecomplex u, u2, xx1, xx2;
doublereal r1, r2, zmh, zph;
} gwav_;
#define gwav_1 gwav_
struct {
integer iplp1, iplp2, iplp3, iplp4;
} plot_;
#define plot_1 plot_
struct {
doublereal salp[600];
} angl_;
#define angl_1 angl_
struct {
doublereal s, b, xj, yj, zj, cabj, sabj, salpj;
doublecomplex exk, eyk, ezk, exs, eys, ezs, exc, eyc, ezc;
doublereal rkh;
integer iexk, ind1, indd1, ind2, indd2, ipgnd;
} dataj_;
#define dataj_1 dataj_
struct {
doublecomplex ssx[256] /* was [16][16] */;
} smat_;
#define smat_1 smat_
union {
struct {
doublecomplex d[800];
} _1;
struct {
doublecomplex y[800];
} _2;
struct {
doublereal gain[800];
} _3;
} scratm_;
#define scratm_1 (scratm_._1)
#define scratm_2 (scratm_._2)
#define scratm_3 (scratm_._3)
struct {
doublereal xo, yo, zo, sn, xsn, ysn;
integer isnor;
} incom_;
#define incom_1 incom_
union {
struct {
doublereal zpk, rkb2;
integer ijx;
} _1;
struct {
doublereal zpk, rkb2;
integer ij;
} _2;
} tmi_;
#define tmi_1 (tmi_._1)
#define tmi_2 (tmi_._2)
struct {
doublereal zpk, rhks;
} tmh_;
#define tmh_1 tmh_
/* Table of constant values */
static integer c__1 = 1;
static doublecomplex c_b48 = {1.,0.};
static integer c__880 = 880;
static integer c__680 = 680;
static integer c__576 = 576;
static integer c__2 = 2;
static integer c__3 = 3;
static integer c__11 = 11;
static integer c__12 = 12;
static integer c__13 = 13;
static integer c__14 = 14;
static integer c__7 = 7;
static integer c__5 = 5;
static integer c__0 = 0;
static integer c_n1 = -1;
static integer c__31 = 31;
static doublereal c_b594 = 0.;
static integer c__16 = 16;
static integer c__17 = 17;
static integer c__18 = 18;
static integer c__19 = 19;
static integer c__20 = 20;
static integer c__602 = 602;
static integer c__193 = 193;
static doublecomplex c_b1190 = {.5,0.};
static integer c__95 = 95;
static integer c__206 = 206;
static integer c__205 = 205;
static integer c__201 = 201;
static integer c__202 = 202;
static integer c__203 = 203;
static integer c__204 = 204;
static integer c__207 = 207;
static integer c__208 = 208;
static integer c__4 = 4;
static integer c__121 = 121;
static integer c__122 = 122;
static integer c__123 = 123;
static integer c__124 = 124;
static integer c__125 = 125;
static integer c__9 = 9;
/* PROGRAM NEC(INPUT,TAPE5=INPUT,OUTPUT,TAPE11,TAPE12,TAPE13,TAPE14, */
/* 1TAPE15,TAPE16,TAPE20,TAPE21) */
/* NUMERICAL ELECTROMAGNETICS CODE (NEC2) DEVELOPED AT LAWRENCE */
/* LIVERMORE LAB., LIVERMORE, CA. (CONTACT G. BURKE AT 415-422-8414 */
/* FOR PROBLEMS WITH THE NEC CODE. FOR PROBLEMS WITH THE VAX IMPLEM- */
/* ENTATION, CONTACT J. BREAKALL AT 415-422-8196 OR E. DOMNING AT 415 */
/* 422-5936) */
/* FILE CREATED 4/11/80. */
/* ***********NOTICE********** */
/* THIS COMPUTER CODE MATERIAL WAS PREPARED AS AN ACCOUNT OF WORK */
/* SPONSORED BY THE UNITED STATES GOVERNMENT. NEITHER THE UNITED */
/* STATES NOR THE UNITED STATES DEPARTMENT OF ENERGY, NOR ANY OF */
/* THEIR EMPLOYEES, NOR ANY OF THEIR CONTRACTORS, SUBCONTRACTORS, OR */
/* THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR */
/* ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY, */
/* COMPLETENESS OR USEFULNESS OF ANY INFORMATION, APPARATUS, PRODUCT */
/* OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT */
/* INFRINGE PRIVATELY-OWNED RIGHTS. */
/* *** */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* Main program */ MAIN__()
{
/* Initialized data */
static char atst[2*22+1] = "CEFRLDGNEXNTXQNEGDRPCMNXENTLPTKHNHPQEKWGCPPL";
static char hpol[6*3+1] = "LINEARRIGHT LEFT ";
static char pnet[6*6+1] = " STRAIGHT CROSSED ";
static doublereal ta = .01745329252;
static doublereal cvel = 299.8;
static integer loadmx = 200;
static integer nsmax = 150;
static integer netmx = 150;
static integer normf = 200;
/* Format strings */
static char fmt_700[] = "(\002$ENTER DATA INPUT FILENAME [HIT RETURN FOR\
TERMINAL\002,\002 INPUT] : \002,/,\002$ >\002)";
static char fmt_701[] = "(a)";
static char fmt_703[] = "(\002$ENTER DATA OUTPUT FILENAME [HIT RETURN FO\
R TERMINAL\002,\002 OUTPUT] : \002,/,\002$ >\002)";
static char fmt_125[] = "(a2,19a4)";
static char fmt_126[] = "(\0021\002)";
static char fmt_127[] = "(///,33x,\002**********************************\
**\002,//,36x,\002NUMERICAL ELECTROMAGNETICS CODE\002,//,33x,\002***********\
*************************\002)";
static char fmt_128[] = "(////,37x,\002- - - - COMMENTS - - - -\002,//)";
static char fmt_129[] = "(25x,20a4)";
static char fmt_130[] = "(///,10x,\002INCORRECT LABEL FOR A COMMENT CAR\
D\002)";
static char fmt_135[] = "(/////)";
static char fmt_137[] = "(1x,\002***** DATA CARD NO.\002,i3,3x,a2,1x,i3,\
3(1x,i5),6(1x,1p,e12.5))";
static char fmt_201[] = "(/,\002 RUN TIME =\002,f10.3)";
static char fmt_138[] = "(///,10x,\002FAULTY DATA CARD LABEL AFTER GEOME\
TRY SECTION\002)";
static char fmt_303[] = "(/,\002 ERROR - \002,a2,\002 CARD IS NOT ALLOWE\
D WITH N.G.F.\002)";
static char fmt_313[] = "(/,\002 NUMBER OF SEGMENTS IN COUPLING CALCULAT\
ION (CP) EXCEE\002,\002DS LIMIT\002)";
static char fmt_139[] = "(///,10x,\002NUMBER OF LOADING CARDS EXCEEDS ST\
ORAGE ALLOTTED\002)";
static char fmt_140[] = "(///,10x,\002DATA FAULT ON LOADING CARD NO.=\
\002,i5,5x,\002ITAG S\002,\002TEP1=\002,i5,\002 IS GREATER THAN ITAG STEP2\
=\002,i5)";
static char fmt_390[] = "(\002 RADIAL WIRE G. S. APPROXIMATION MAY NOT B\
E USED WITH SO\002,\002MMERFELD GROUND OPTION\002)";
static char fmt_141[] = "(///,10x,\002NUMBER OF EXCITATION CARDS EXCEEDS\
STORAGE ALLO\002,\002TTED\002)";
static char fmt_142[] = "(///,10x,\002NUMBER OF NETWORK CARDS EXCEEDS ST\
ORAGE ALLOTTED\002)";
static char fmt_143[] = "(///,10x,\002WHEN MULTIPLE FREQUENCIES ARE REQU\
ESTED, ONLY ONE NEAR FIELD CARD CAN BE USED -\002,/,10x,\002LAST CARD READ \
IS USED\002)";
static char fmt_302[] = "(\002 ERROR - N.G.F. IN USE. CANNOT WRITE NEW \
N.G.F.\002)";
static char fmt_145[] = "(////,33x,\002- - - - - - FREQUENCY - - - - - \
-\002,//,36x,\002FR\002,\002EQUENCY=\002,1p,e11.4,\002 MHZ\002,/,36x,\002WAV\
ELENGTH=\002,e11.4,\002 METERS\002)";
static char fmt_196[] = "(////,20x,\002APPROXIMATE INTEGRATION EMPLOYED \
FOR SEGMENT\002,\002S MORE THAN\002,f8.3,\002 WAVELENGTHS APART\002)";
static char fmt_321[] = "(/,20x,\002THE EXTENDED THIN WIRE KERNEL WILL B\
E USED\002)";
static char fmt_146[] = "(///,30x,\002 - - - STRUCTURE IMPEDANCE LOADING\
- - -\002)";
static char fmt_147[] = "(/,35x,\002THIS STRUCTURE IS NOT LOADED\002)";
static char fmt_327[] = "(/,35x,\002 LOADING ONLY IN N.G.F. SECTION\002)";
static char fmt_148[] = "(///,34x,\002- - - ANTENNA ENVIRONMENT - - -\
\002,/)";
static char fmt_170[] = "(40x,\002RADIAL WIRE GROUND SCREEN\002,/,40x,\
i5,\002 WIRES\002,/,40x,\002WIRE LENGTH=\002,f8.2,\002 METERS\002,/,40x,\002\
WIRE RADIUS=\002,1p,e10.3,\002 METERS\002)";
static char fmt_149[] = "(40x,\002MEDIUM UNDER SCREEN -\002)";
static char fmt_391[] = "(40x,\002FINITE GROUND. REFLECTION COEFFICIENT\
APPROXIMATION\002)";
static char fmt_393[] = "(/,\002 ERROR IN GROUND PARAMETERS -\002,/,\002\
COMPLEX DIELECTRIC\002,\002 CONSTANT FROM FILE IS\002,1p,2e12.5,/,32x,\002R\
EQUESTED\002,2e12.5)";
static char fmt_392[] = "(40x,\002FINITE GROUND. SOMMERFELD SOLUTION\
\002)";
static char fmt_150[] = "(40x,\002RELATIVE DIELECTRIC CONST.=\002,f7.3,/\
,40x,\002CONDUCTIV\002,\002ITY=\002,1p,e10.3,\002 MHOS/METER\002,/,40x,\002C\
OMPLEX DIELECTRIC CONSTANT=\002,2e12.5)";
static char fmt_151[] = "(42x,\002PERFECT GROUND\002)";
static char fmt_152[] = "(44x,\002FREE SPACE\002)";
static char fmt_153[] = "(///,32x,\002- - - MATRIX TIMING - - -\002,//,2\
4x,\002FILL=\002,f9.3,\002 SEC., FACTOR=\002,f9.3,\002 SEC.\002)";
static char fmt_154[] = "(///,40x,\002- - - EXCITATION - - -\002)";
static char fmt_156[] = "(/,31x,\002POSITION (METERS)\002,14x,\002ORIENT\
ATION (DEG)=/\002,28x,\002X\002,12x,\002Y\002,12x,\002Z\002,10x,\002ALPHA\
\002,5x,\002BETA\002,4x,\002DIPOLE MOMENT\002,//,4x,\002CURRENT SOURCE\002,1\
x,3(3x,f10.5),1x,2(3x,f7.2),4x,f8.3)";
static char fmt_155[] = "(/,4x,\002PLANE WAVE\002,4x,\002THETA=\002,f7\
.2,\002 DEG, PHI=\002,f7.2,\002 DEG, ETA=\002,f7.2,\002 DEG, TYPE -\002,a\
6,\002= AXIAL RATIO=\002,f6.3)";
static char fmt_158[] = "(///,44x,\002- - - NETWORK DATA - - -\002)";
static char fmt_159[] = "(/,6x,\002- FROM - - TO -\002,11x,\002TRANSM\
ISSION LINE\002,15x,\002- - SHUNT ADMITTANCES (MHOS) - -\002,14x,\002LINE\
\002,/,6x,\002TAG SEG.\002,\002 TAG SEG.\002,6x,\002IMPEDANCE\002,6x,\
\002LENGTH\002,12x,\002- END ONE -\002,17x,\002- END TWO -\002,12x,\002TYP\
E\002,/,6x,\002NO. NO. NO. NO.\002,9x,\002OHM'S\002,8x,\002METERS\002,\
9x,\002REAL\002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\002IMAG.\002)";
static char fmt_160[] = "(/,6x,\002- FROM -\002,4x,\002- TO -\002,26x\
,\002- - ADMITTANCE MATRIX\002,\002 ELEMENTS (MHOS) - -\002,/,6x,\002TAG\
SEG. TAG SEG.\002,13x,\002(ON\002,\002E,ONE)\002,19x,\002(ONE,TWO)\002,\
19x,\002(TWO,TWO)\002,/,6x,\002NO. NO. NO.\002,\002 NO.\002,8x,\002REAL\
\002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\002IMAG.\002,9x,\002REAL\002,10x,\
\002IMAG.\002)";
static char fmt_157[] = "(4x,4(i5,1x),1p,6(3x,e11.4),3x,a6,a2)";
static char fmt_161[] = "(///,29x,\002- - - CURRENTS AND LOCATION - - \
-\002,//,33x,\002DIS\002,\002TANCES IN WAVELENGTHS\002)";
static char fmt_162[] = "(//,2x,\002SEG.\002,2x,\002TAG\002,4x,\002COORD\
. OF SEG. CENTER\002,5x,\002SEG.\002,12x,\002- - - CURRENT (AMPS) - - -\002,\
/,2x,\002NO.\002,3x,\002NO.\002,5x,\002X\002,8x,\002Y\002,8x,\002Z\002,6x\
,\002LENGTH\002,5x,\002REAL\002,8x,\002IMAG.\002,7x,\002MAG.\002,8x,\002PHASE\
\002)";
static char fmt_163[] = "(///,33x,\002- - - RECEIVING PATTERN PARAMETERS\
- - -\002,/,43x,\002ETA=\002,f7.2,\002 DEGREES\002,/,43x,\002TYPE -\002,a6,\
/,43x,\002AXIAL RATIO=\002,f6.3,//,11x,\002THETA\002,6x,\002PHI\002,10x,\002\
- CURRENT -\002,9x,\002SEG\002,/,11x,\002(DEG)\002,5x,\002(DEG)\002,7x,\
\002MAGNITUDE\002,4x,\002PHASE\002,6x,\002NO.\002,/)";
static char fmt_164[] = "(10x,2(f7.2,3x),1x,1p,e11.4,3x,0p,f7.2,4x,i5)";
static char fmt_165[] = "(1x,2i5,3f9.4,f9.5,1x,1p,3e12.4,0p,f9.3)";
static char fmt_315[] = "(///,34x,\002- - - CHARGE DENSITIES - - -\002,/\
/,36x,\002DISTANCES IN WAVELENGTHS\002,///,2x,\002SEG.\002,2x,\002TAG\002,4x,\
\002COORD. OF SEG. CENTER\002,5x,\002SEG.\002,10x,\002CHARGE DENSITY (COULOM\
BS/METER)\002,/,2x,\002NO.\002,3x,\002NO.\002,5x,\002X\002,8x,\002Y\002,8x\
,\002Z\002,6x,\002LENGTH\002,5x,\002REAL\002,8x,\002IMAG.\002,7x,\002MAG.\
\002,8x,\002PHASE\002)";
static char fmt_197[] = "(////,41x,\002- - - - SURFACE PATCH CURRENTS - \
- - -\002,//,50x,\002DISTANCE IN WAVELENGTHS\002,/,50x,\002CURRENT IN AMPS/M\
ETER\002,//,28x,\002- - SURFACE COMPONENTS - -\002,19x,\002- - - RECTANGULAR\
COM\002,\002PONENTS - - -\002,/,6x,\002PATCH CENTER\002,6x,\002TANGENT VECT\
OR 1\002,3x,\002TANGENT VECTOR 2\002,11x,\002X\002,19x,\002Y\002,19x,\002\
Z\002,/,5x,\002X\002,6x,\002Y\002,6x,\002Z\002,5x,\002MAG.\002,7x,\002PHAS\
E\002,3x,\002MAG.\002,7x,\002PHASE\002,3(4x,\002REAL\002,6x,\002IMAG.\002))";
static char fmt_198[] = "(1x,i4,/,1x,3f7.3,2(1p,e11.4,0p,f8.2),1p,6e10.2)"
;
static char fmt_166[] = "(///,40x,\002- - - POWER BUDGET - - -\002,//,43\
x,\002INPUT PO\002,\002WER =\002,1p,e11.4,\002 WATTS\002,/,43x,\002RADIATE\
D POWER=\002,e11.4,\002 WATTS\002,/,43x,\002STRUCTURE LOSS=\002,e11.4,\002 W\
ATTS\002,/,43x,\002NETWORK LOSS =\002,e11.4,\002 WATTS\002,/,43x,\002EFFICI\
ENCY =\002,0p,f7.2,\002 PERCENT\002)";
static char fmt_181[] = "(///,4x,\002RECEIVING PATTERN STORAGE TOO SMALL\
,ARRAY TRUNCA\002,\002TED\002)";
static char fmt_182[] = "(///,32x,\002- - - NORMALIZED RECEIVING PATTERN\
- - -\002,/,41x,\002NORMALIZATION FACTOR=\002,1p,e11.4,/,41x,\002ETA=\002,0\
p,f7.2,\002 DEGREES\002,/,41x,\002TYPE -\002,a6,/,41x,\002AXIAL RATIO=\002,f\
6.3,/,41x,\002SEGMENT NO.=\002,i5,//,21x,\002THETA\002,6x,\002PHI\002,9x,\
\002- PATTERN -\002,/,21x,\002(DEG)\002,5x,\002(DEG)\002,8x,\002DB\002,8x\
,\002MAGNITUDE\002,/)";
static char fmt_183[] = "(20x,2(f7.2,3x),1x,f7.2,4x,1p,e11.4)";
static char fmt_184[] = "(///,36x,\002- - - INPUT IMPEDANCE DATA - - \
-\002,/,45x,\002SO\002,\002URCE SEGMENT NO.\002,i4,/,45x,\002NORMALIZATION F\
ACTOR=\002,1p,e12.5,//,7x,\002FREQ.\002,13x,\002- - UNNORMALIZED IMPEDANCE\
- -\002,21x,\002-\002\002 - NORMALIZED IMPEDANCE - -\002,/,19x,\002RES\
ISTANCE\002,4x,\002REACTA\002,\002NCE\002,6x,\002MAGNITUDE\002,4x,\002PHAS\
E\002,7x,\002RESISTANCE\002,4x,\002REACTANCE\002,6x,\002MAGNITUDE\002,4x,\
\002PHASE\002,/,8x,\002MHZ\002,11x,\002OHMS\002,10x,\002OHMS\002,11x,\002OHMS\
\002,5x,\002DEGREES\002,47x,\002DEGREES\002,/)";
static char fmt_185[] = "(///,4x,\002STORAGE FOR IMPEDANCE NORMALIZATION\
TOO SMALL, A\002,\002RRAY TRUNCATED\002)";
static char fmt_186[] = "(3x,f9.3,2x,1p,2(2x,e12.5),3x,e12.5,2x,0p,f7.2,\
2x,1p,2(2x,e12.5),3x,e12.5,2x,0p,f7.2)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5;
olist o__1;
/* Builtin functions */
integer s_wsfe(), e_wsfe(), s_rsfe(), do_fio(), e_rsfe(), s_cmp(), f_open(
);
/* Subroutine */ int s_stop();
double z_abs();
void z_sqrt(), z_div();
integer s_rsue(), do_uio(), e_rsue();
double sqrt(), d_imag();
integer s_wsle(), do_lio(), e_wsle();
double pow_di();
/* Local variables */
static doublereal cmag;
extern doublereal cang_();
static doublereal epha;
extern /* Subroutine */ int load_();
static integer iped;
static doublereal etha;
static doublecomplex epsc, curi;
static integer nfrq, iexk, ifrq, nthi, nphi, jump;
static doublereal ethm, ephm, fmhz1;
static integer itmp1, itmp2, itmp3, itmp4, itmp5;
extern /* Subroutine */ int facgf_();
static integer i, j;
extern /* Subroutine */ int fbngf_();
static integer ldtag[200];
extern /* Subroutine */ int cmngf_();
static integer nphic, iptag, irngf;
extern /* Subroutine */ int cmset_();
static doublereal fnorm[200];
static integer ldtyp[200];
static doublereal xtemp[600];
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal ytemp[600], ztemp[600];
extern /* Subroutine */ int error_();
static doublereal extim;
static integer mpcnt, iflow;
static doublereal fmhzs, phiss;
static integer iptaq;
extern /* Subroutine */ int gfout_();
static integer nthic;
extern /* Subroutine */ int etmns_(), netwk_();
static integer isave;
extern /* Subroutine */ int nfpat_(), rdpat_(), str0pc_();
static doublecomplex fj;
static doublereal fr;
static doublecomplex ex, ey, ez;
static integer ldtagf[200], ix[800];
static char infile[80];
extern /* Subroutine */ int datagn_(), readmn_(), fblock_();
static integer iptagf;
static doublereal ph, delfrq;
static integer ldtagt[200];
static doublereal bitemp[600];
extern /* Subroutine */ int secnds_();
static char otfile[80];
extern /* Subroutine */ int factrs_();
static integer iptflg;
extern integer isegno_();
static integer iptaqf, iptagt;
extern /* Subroutine */ int couple_();
static integer iptflq;
static doublereal thetis, sitemp[600];
static integer ifrtmp, iptaqt, ifrtmw, iresrv;
static doublereal fr2, zpnorm;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
extern doublereal db20_();
static integer ib11, ic11, id11;
#define sab ((doublereal *)&data_1 + 3600)
static char ain[2];
static integer inc;
static doublecomplex eph, eth;
static doublereal zlr[200], zli[200], zlc[200];
static integer ix11, igo;
static doublereal rkh;
static integer mhz;
static doublereal tim, tim1, tim2, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6,
xpr1, xpr2, xpr3, xpr4, xpr5;
/* Fortran I/O blocks */
static cilist io___21 = { 0, 6, 0, fmt_700, 0 };
static cilist io___22 = { 1, 5, 0, fmt_701, 0 };
static cilist io___24 = { 0, 6, 0, fmt_703, 0 };
static cilist io___25 = { 1, 5, 0, fmt_701, 0 };
static cilist io___32 = { 0, 5, 0, fmt_125, 0 };
static cilist io___35 = { 0, 6, 0, fmt_126, 0 };
static cilist io___36 = { 0, 6, 0, fmt_127, 0 };
static cilist io___37 = { 0, 6, 0, fmt_128, 0 };
static cilist io___38 = { 0, 6, 0, fmt_129, 0 };
static cilist io___39 = { 0, 6, 0, fmt_130, 0 };
static cilist io___46 = { 0, 6, 0, fmt_135, 0 };
static cilist io___66 = { 0, 6, 0, fmt_137, 0 };
static cilist io___67 = { 0, 6, 0, fmt_201, 0 };
static cilist io___68 = { 0, 6, 0, fmt_138, 0 };
static cilist io___70 = { 0, 6, 0, fmt_303, 0 };
static cilist io___73 = { 0, 6, 0, fmt_313, 0 };
static cilist io___74 = { 0, 6, 0, fmt_139, 0 };
static cilist io___79 = { 0, 6, 0, fmt_140, 0 };
static cilist io___83 = { 0, 6, 0, fmt_303, 0 };
static cilist io___84 = { 0, 6, 0, fmt_390, 0 };
static cilist io___85 = { 0, 6, 0, fmt_141, 0 };
static cilist io___95 = { 0, 6, 0, fmt_142, 0 };
static cilist io___102 = { 0, 6, 0, fmt_143, 0 };
static cilist io___103 = { 0, 6, 0, fmt_302, 0 };
static cilist io___113 = { 0, 6, 0, fmt_145, 0 };
static cilist io___114 = { 0, 6, 0, fmt_196, 0 };
static cilist io___115 = { 0, 6, 0, fmt_321, 0 };
static cilist io___117 = { 0, 6, 0, fmt_146, 0 };
static cilist io___118 = { 0, 6, 0, fmt_147, 0 };
static cilist io___119 = { 0, 6, 0, fmt_327, 0 };
static cilist io___120 = { 0, 6, 0, fmt_148, 0 };
static cilist io___122 = { 0, 6, 0, fmt_170, 0 };
static cilist io___123 = { 0, 6, 0, fmt_149, 0 };
static cilist io___124 = { 0, 6, 0, fmt_391, 0 };
static cilist io___125 = { 0, 21, 0, 0, 0 };
static cilist io___126 = { 0, 6, 0, fmt_393, 0 };
static cilist io___127 = { 0, 6, 0, fmt_392, 0 };
static cilist io___128 = { 0, 6, 0, fmt_150, 0 };
static cilist io___129 = { 0, 6, 0, fmt_151, 0 };
static cilist io___130 = { 0, 6, 0, fmt_152, 0 };
static cilist io___135 = { 0, 6, 0, fmt_153, 0 };
static cilist io___139 = { 0, 6, 0, fmt_154, 0 };
static cilist io___140 = { 0, 6, 0, fmt_156, 0 };
static cilist io___141 = { 0, 6, 0, fmt_155, 0 };
static cilist io___142 = { 0, 6, 0, fmt_158, 0 };
static cilist io___143 = { 0, 6, 0, fmt_159, 0 };
static cilist io___144 = { 0, 6, 0, fmt_160, 0 };
static cilist io___146 = { 0, 6, 0, fmt_157, 0 };
static cilist io___148 = { 0, 6, 0, fmt_161, 0 };
static cilist io___149 = { 0, 6, 0, fmt_162, 0 };
static cilist io___150 = { 0, 6, 0, fmt_163, 0 };
static cilist io___156 = { 0, 6, 0, fmt_164, 0 };
static cilist io___157 = { 0, 6, 0, fmt_165, 0 };
static cilist io___158 = { 0, 8, 0, 0, 0 };
static cilist io___159 = { 0, 8, 0, 0, 0 };
static cilist io___160 = { 0, 6, 0, fmt_315, 0 };
static cilist io___161 = { 0, 6, 0, fmt_165, 0 };
static cilist io___162 = { 0, 6, 0, fmt_197, 0 };
static cilist io___172 = { 0, 6, 0, fmt_198, 0 };
static cilist io___173 = { 0, 8, 0, 0, 0 };
static cilist io___174 = { 0, 8, 0, 0, 0 };
static cilist io___175 = { 0, 8, 0, 0, 0 };
static cilist io___176 = { 0, 8, 0, 0, 0 };
static cilist io___177 = { 0, 6, 0, fmt_166, 0 };
static cilist io___178 = { 0, 6, 0, fmt_135, 0 };
static cilist io___179 = { 0, 6, 0, fmt_135, 0 };
static cilist io___180 = { 0, 6, 0, fmt_181, 0 };
static cilist io___181 = { 0, 6, 0, fmt_182, 0 };
static cilist io___182 = { 0, 6, 0, fmt_183, 0 };
static cilist io___183 = { 0, 6, 0, fmt_135, 0 };
static cilist io___184 = { 0, 6, 0, fmt_184, 0 };
static cilist io___185 = { 0, 6, 0, fmt_184, 0 };
static cilist io___186 = { 0, 6, 0, fmt_185, 0 };
static cilist io___187 = { 0, 6, 0, fmt_186, 0 };
static cilist io___188 = { 0, 6, 0, fmt_135, 0 };
/*< CHARACTER AIN*2, ATST*2, INFILE*80, OTFILE*80 >*/
/* *** */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/* INTEGER AIN,ATST,PNET,HPOL */
/* REAL RHPOL,PNET */
/*< >*/
/*< >*/
/*< COMPLEX AR1, AR2, AR3, EPSCF, FRATI >*/
/*< COMMON /CMB/ CM(90000) >*/
/*< >*/
/*< >*/
/*< COMMON /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
/*< >*/
/*< >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/* *** */
/*< COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
/* *** */
/*< COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
/*< DIMENSION CAB(1), SAB(1), X2(1), Y2(1), Z2(1) >*/
/*< >*/
/*< DIMENSION IX( N2M) >*/
/*< DIMENSION FNORM(200) >*/
/* *** */
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET),(X2,SI),(Y2,ALP),(Z2,BET) >*/
/*< >*/
/*< CHARACTER*2 ATST(22) >*/
/*< CHARACTER*6 HPOL(3) >*/
/*< CHARACTER*6 PNET(6) >*/
/*< >*/
/*< DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/ >*/
/*< DATA PNET/6H ,2H ,6HSTRAIG,2HHT,6HCROSSE,1HD/ >*/
/*< DATA TA/1.745329252D-02/, CVEL/299.8/ >*/
/* *** */
/*< DATA LOADMX, NSMAX, NETMX/200,150,150/, NORMF/200/ >*/
/*< 706 CONTINUE >*/
L706:
/*< PRINT700 >*/
s_wsfe(&io___21);
e_wsfe();
/*< >*/
/*< 701 FORMAT(A) >*/
/* L701: */
/*< READ( *,701,ERR=702) INFILE >*/
i__1 = s_rsfe(&io___22);
if (i__1 != 0) {
goto L702;
}
i__1 = do_fio(&c__1, infile, 80L);
if (i__1 != 0) {
goto L702;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L702;
}
/*< CALL STR0PC( INFILE, INFILE) >*/
str0pc_(infile, infile, 80L, 80L);
/* JCB OPEN (UNIT=5,FILE=INFILE,STATUS='OLD',READONLY,ERR=702) */
/*< IF( INFILE.NE.' ') THEN >*/
if (s_cmp(infile, " ", 80L, 1L) != 0) {
/*< OPEN ( UNIT=5,FILE=INFILE,STATUS='OLD',ERR=702,BLANK='NULL') >*/
o__1.oerr = 1;
o__1.ounit = 5;
o__1.ofnmlen = 80;
o__1.ofnm = infile;
o__1.orl = 0;
o__1.osta = "OLD";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = "NULL";
i__1 = f_open(&o__1);
if (i__1 != 0) {
goto L702;
}
/*< ENDIF >*/
}
/*< 707 CONTINUE >*/
L707:
/*< PRINT703 >*/
s_wsfe(&io___24);
e_wsfe();
/*< >*/
/*< READ( *,701,ERR=704) OTFILE >*/
i__1 = s_rsfe(&io___25);
if (i__1 != 0) {
goto L704;
}
i__1 = do_fio(&c__1, otfile, 80L);
if (i__1 != 0) {
goto L704;
}
i__1 = e_rsfe();
if (i__1 != 0) {
goto L704;
}
/*< CALL STR0PC( OTFILE, OTFILE) >*/
str0pc_(otfile, otfile, 80L, 80L);
/*< IF( OTFILE.NE.' ') THEN >*/
if (s_cmp(otfile, " ", 80L, 1L) != 0) {
/*< OPEN ( UNIT=6,FILE=OTFILE,STATUS='NEW',ERR=704) >*/
o__1.oerr = 1;
o__1.ounit = 6;
o__1.ofnmlen = 80;
o__1.ofnm = otfile;
o__1.orl = 0;
o__1.osta = "NEW";
o__1.oacc = 0;
o__1.ofm = 0;
o__1.oblnk = 0;
i__1 = f_open(&o__1);
if (i__1 != 0) {
goto L704;
}
/*< ENDIF >*/
}
/*< GOTO 705 >*/
goto L705;
/*< 702 CALL ERROR >*/
L702:
error_();
/*< GOTO 706 >*/
goto L706;
/*< 704 CALL ERROR >*/
L704:
error_();
/*< GOTO 707 >*/
goto L707;
/* *** */
/*< 705 CONTINUE >*/
L705:
/*< CALL SECNDS(EXTIM) >*/
secnds_(&extim);
/*< FJ=(0.,1.) >*/
fj.r = 0., fj.i = 1.;
/*< LD=600 >*/
data_1.ld = 600;
/*< NXA(1)=0 >*/
ggrid_1.nxa[0] = 0;
/*< IRESRV=90000 >*/
iresrv = 90000;
/* *** */
/*< 1 KCOM=0 >*/
L1:
save_1.kcom = 0;
/*< IFRTMW=0 >*/
ifrtmw = 0;
/* *** */
/*< IFRTMP=0 >*/
ifrtmp = 0;
/*< 2 KCOM= KCOM+1 >*/
L2:
++save_1.kcom;
/*< IF( KCOM.GT.5) KCOM=5 >*/
if (save_1.kcom > 5) {
save_1.kcom = 5;
}
/* *** */
/*< READ( 5,125) AIN,( COM( I, KCOM), I=1,19) >*/
s_rsfe(&io___32);
do_fio(&c__1, ain, 2L);
for (i = 1; i <= 19; ++i) {
do_fio(&c__1, (char *)&save_1.com[i + save_1.kcom * 19 - 20], (ftnlen)
sizeof(doublereal));
}
e_rsfe();
/* *** */
/*< CALL STR0PC( AIN, AIN) >*/
str0pc_(ain, ain, 2L, 2L);
/*< IF( KCOM.GT.1) GOTO 3 >*/
if (save_1.kcom > 1) {
goto L3;
}
/*< WRITE( 6,126) >*/
s_wsfe(&io___35);
e_wsfe();
/*< WRITE( 6,127) >*/
s_wsfe(&io___36);
e_wsfe();
/*< WRITE( 6,128) >*/
s_wsfe(&io___37);
e_wsfe();
/*< 3 WRITE( 6,129) ( COM( I, KCOM), I=1,19) >*/
L3:
s_wsfe(&io___38);
for (i = 1; i <= 19; ++i) {
do_fio(&c__1, (char *)&save_1.com[i + save_1.kcom * 19 - 20], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
/*< IF( AIN.EQ. ATST(11)) GOTO 2 >*/
if (s_cmp(ain, atst + 20, 2L, 2L) == 0) {
goto L2;
}
/*< IF( AIN.EQ. ATST(1)) GOTO 4 >*/
if (s_cmp(ain, atst, 2L, 2L) == 0) {
goto L4;
}
/*< WRITE( 6,130) >*/
s_wsfe(&io___39);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 4 CONTINUE >*/
L4:
/*< DO 5 I=1, LD >*/
i__1 = data_1.ld;
for (i = 1; i <= i__1; ++i) {
/*< 5 ZARRAY( I)=(0.,0.) >*/
/* L5: */
i__2 = i - 1;
zload_1.zarray[i__2].r = 0., zload_1.zarray[i__2].i = 0.;
}
/*< MPCNT=0 >*/
mpcnt = 0;
/* SET UP GEOMETRY DATA IN SUBROUTINE DATAGN */
/*< IMAT=0 >*/
matpar_1.imat = 0;
/*< CALL DATAGN >*/
datagn_();
/*< IFLOW=1 >*/
iflow = 1;
/* CORE ALLOCATION FOR ARRAYS B, C, AND D FOR N.G.F. SOLUTION */
/*< IF( IMAT.EQ.0) GOTO 326 >*/
if (matpar_1.imat == 0) {
goto L326;
}
/*< NEQ= N1+2* M1 >*/
netcx_1.neq = data_1.n1 + (data_1.m1 << 1);
/*< NEQ2= N- N1+2*( M- M1)+ NSCON+2* NPCON >*/
netcx_1.neq2 = data_1.n - data_1.n1 + (data_1.m - data_1.m1 << 1) +
segj_1.nscon + (segj_1.npcon << 1);
/*< CALL FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11) >*/
fbngf_(&netcx_1.neq, &netcx_1.neq2, &iresrv, &ib11, &ic11, &id11, &ix11);
/*< GOTO 6 >*/
goto L6;
/*< 326 NEQ= N+2* M >*/
L326:
netcx_1.neq = data_1.n + (data_1.m << 1);
/*< NEQ2=0 >*/
netcx_1.neq2 = 0;
/*< IB11=1 >*/
ib11 = 1;
/*< IC11=1 >*/
ic11 = 1;
/*< ID11=1 >*/
id11 = 1;
/*< IX11=1 >*/
ix11 = 1;
/*< ICASX=0 >*/
matpar_1.icasx = 0;
/*< 6 NPEQ= NP+2* MP >*/
L6:
netcx_1.npeq = data_1.np + (data_1.mp << 1);
/* DEFAULT VALUES FOR INPUT PARAMETERS AND FLAGS */
/* *** */
/*< WRITE( 6,135) >*/
s_wsfe(&io___46);
e_wsfe();
/*< IPLP1=0 >*/
plot_1.iplp1 = 0;
/*< IPLP2=0 >*/
plot_1.iplp2 = 0;
/*< IPLP3=0 >*/
plot_1.iplp3 = 0;
/* *** */
/*< IPLP4=0 >*/
plot_1.iplp4 = 0;
/*< IGO=1 >*/
igo = 1;
/*< FMHZS= CVEL >*/
fmhzs = cvel;
/*< NFRQ=1 >*/
nfrq = 1;
/*< RKH=1. >*/
rkh = 1.;
/*< IEXK=0 >*/
iexk = 0;
/*< IXTYP=0 >*/
fpat_1.ixtyp = 0;
/*< NLOAD=0 >*/
zload_1.nload = 0;
/*< NONET=0 >*/
netcx_1.nonet = 0;
/*< NEAR=-1 >*/
fpat_1.near = -1;
/*< IPTFLG=-2 >*/
iptflg = -2;
/*< IPTFLQ=-1 >*/
iptflq = -1;
/*< IFAR=-1 >*/
gnd_1.ifar = -1;
/*< ZRATI=(1.,0.) >*/
gnd_1.zrati.r = 1., gnd_1.zrati.i = 0.;
/*< IPED=0 >*/
iped = 0;
/*< IRNGF=0 >*/
irngf = 0;
/*< NCOUP=0 >*/
yparm_1.ncoup = 0;
/*< ICOUP=0 >*/
yparm_1.icoup = 0;
/*< IF( ICASX.GT.0) GOTO 14 >*/
if (matpar_1.icasx > 0) {
goto L14;
}
/*< FMHZ= CVEL >*/
save_1.fmhz = cvel;
/*< NLODF=0 >*/
zload_1.nlodf = 0;
/*< KSYMP=1 >*/
gnd_1.ksymp = 1;
/*< NRADL=0 >*/
gnd_1.nradl = 0;
/* MAIN INPUT SECTION - STANDARD READ STATEMENT - JUMPS TO APPRO- */
/* PRIATE SECTION FOR SPECIFIC PARAMETER SET UP */
/* 14 READ(5,136)AIN,ITMP1,ITMP2,ITMP3,ITMP4,TMP1,TMP2,TMP3,TMP4,TMP5,
*/
/* 1TMP6 */
/* *** */
/*< IPERF=0 >*/
gnd_1.iperf = 0;
/* *** */
/*< >*/
L14:
readmn_(ain, &itmp1, &itmp2, &itmp3, &itmp4, &tmp1, &tmp2, &tmp3, &tmp4, &
tmp5, &tmp6, 2L);
/*< MPCNT= MPCNT+1 >*/
++mpcnt;
/*< >*/
s_wsfe(&io___66);
do_fio(&c__1, (char *)&mpcnt, (ftnlen)sizeof(integer));
do_fio(&c__1, ain, 2L);
do_fio(&c__1, (char *)&itmp1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itmp2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itmp3, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( AIN.EQ. ATST(2)) GOTO 16 >*/
if (s_cmp(ain, atst + 2, 2L, 2L) == 0) {
goto L16;
}
/*< IF( AIN.EQ. ATST(3)) GOTO 17 >*/
if (s_cmp(ain, atst + 4, 2L, 2L) == 0) {
goto L17;
}
/*< IF( AIN.EQ. ATST(4)) GOTO 21 >*/
if (s_cmp(ain, atst + 6, 2L, 2L) == 0) {
goto L21;
}
/*< IF( AIN.EQ. ATST(5)) GOTO 24 >*/
if (s_cmp(ain, atst + 8, 2L, 2L) == 0) {
goto L24;
}
/*< IF( AIN.EQ. ATST(6)) GOTO 28 >*/
if (s_cmp(ain, atst + 10, 2L, 2L) == 0) {
goto L28;
}
/*< IF( AIN.EQ. ATST(14)) GOTO 28 >*/
if (s_cmp(ain, atst + 26, 2L, 2L) == 0) {
goto L28;
}
/*< IF( AIN.EQ. ATST(15)) GOTO 31 >*/
if (s_cmp(ain, atst + 28, 2L, 2L) == 0) {
goto L31;
}
/*< IF( AIN.EQ. ATST(18)) GOTO 319 >*/
if (s_cmp(ain, atst + 34, 2L, 2L) == 0) {
goto L319;
}
/*< IF( AIN.EQ. ATST(7)) GOTO 37 >*/
if (s_cmp(ain, atst + 12, 2L, 2L) == 0) {
goto L37;
}
/*< IF( AIN.EQ. ATST(8)) GOTO 32 >*/
if (s_cmp(ain, atst + 14, 2L, 2L) == 0) {
goto L32;
}
/*< IF( AIN.EQ. ATST(17)) GOTO 208 >*/
if (s_cmp(ain, atst + 32, 2L, 2L) == 0) {
goto L208;
}
/*< IF( AIN.EQ. ATST(9)) GOTO 34 >*/
if (s_cmp(ain, atst + 16, 2L, 2L) == 0) {
goto L34;
}
/*< IF( AIN.EQ. ATST(10)) GOTO 36 >*/
if (s_cmp(ain, atst + 18, 2L, 2L) == 0) {
goto L36;
}
/*< IF( AIN.EQ. ATST(16)) GOTO 305 >*/
if (s_cmp(ain, atst + 30, 2L, 2L) == 0) {
goto L305;
}
/*< IF( AIN.EQ. ATST(19)) GOTO 320 >*/
if (s_cmp(ain, atst + 36, 2L, 2L) == 0) {
goto L320;
}
/*< IF( AIN.EQ. ATST(12)) GOTO 1 >*/
if (s_cmp(ain, atst + 22, 2L, 2L) == 0) {
goto L1;
}
/*< IF( AIN.EQ. ATST(20)) GOTO 322 >*/
if (s_cmp(ain, atst + 38, 2L, 2L) == 0) {
goto L322;
}
/* *** */
/*< IF( AIN.EQ. ATST(21)) GOTO 304 >*/
if (s_cmp(ain, atst + 40, 2L, 2L) == 0) {
goto L304;
}
/* *** */
/*< IF( AIN.EQ. ATST(22)) GOTO 330 >*/
if (s_cmp(ain, atst + 42, 2L, 2L) == 0) {
goto L330;
}
/*< IF( AIN.NE. ATST(13)) GOTO 15 >*/
if (s_cmp(ain, atst + 24, 2L, 2L) != 0) {
goto L15;
}
/*< CALL SECNDS( TMP1) >*/
secnds_(&tmp1);
/*< TMP1= TMP1- EXTIM >*/
tmp1 -= extim;
/*< WRITE( 6,201) TMP1 >*/
s_wsfe(&io___67);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 15 WRITE( 6,138) >*/
L15:
s_wsfe(&io___68);
e_wsfe();
/* FREQUENCY PARAMETERS */
/*< STOP >*/
s_stop("", 0L);
/*< 16 IFRQ= ITMP1 >*/
L16:
ifrq = itmp1;
/*< IF( ICASX.EQ.0) GOTO 8 >*/
if (matpar_1.icasx == 0) {
goto L8;
}
/*< WRITE( 6,303) AIN >*/
s_wsfe(&io___70);
do_fio(&c__1, ain, 2L);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 8 NFRQ= ITMP2 >*/
L8:
nfrq = itmp2;
/*< IF( NFRQ.EQ.0) NFRQ=1 >*/
if (nfrq == 0) {
nfrq = 1;
}
/*< FMHZ= TMP1 >*/
save_1.fmhz = tmp1;
/*< DELFRQ= TMP2 >*/
delfrq = tmp2;
/*< IF( IPED.EQ.1) ZPNORM=0. >*/
if (iped == 1) {
zpnorm = 0.;
}
/*< IGO=1 >*/
igo = 1;
/*< IFLOW=1 >*/
iflow = 1;
/* MATRIX INTEGRATION LIMIT */
/*< GOTO 14 >*/
goto L14;
/*< 305 RKH= TMP1 >*/
L305:
rkh = tmp1;
/*< IF( IGO.GT.2) IGO=2 >*/
if (igo > 2) {
igo = 2;
}
/*< IFLOW=1 >*/
iflow = 1;
/* EXTENDED THIN WIRE KERNEL OPTION */
/*< GOTO 14 >*/
goto L14;
/*< 320 IEXK=1 >*/
L320:
iexk = 1;
/*< IF( ITMP1.EQ.-1) IEXK=0 >*/
if (itmp1 == -1) {
iexk = 0;
}
/*< IF( IGO.GT.2) IGO=2 >*/
if (igo > 2) {
igo = 2;
}
/*< IFLOW=1 >*/
iflow = 1;
/* MAXIMUM COUPLING BETWEEN ANTENNAS */
/*< GOTO 14 >*/
goto L14;
/*< 304 IF( IFLOW.NE.2) NCOUP=0 >*/
L304:
if (iflow != 2) {
yparm_1.ncoup = 0;
}
/*< ICOUP=0 >*/
yparm_1.icoup = 0;
/*< IFLOW=2 >*/
iflow = 2;
/*< IF( ITMP2.EQ.0) GOTO 14 >*/
if (itmp2 == 0) {
goto L14;
}
/*< NCOUP= NCOUP+1 >*/
++yparm_1.ncoup;
/*< IF( NCOUP.GT.5) GOTO 312 >*/
if (yparm_1.ncoup > 5) {
goto L312;
}
/*< NCTAG( NCOUP)= ITMP1 >*/
yparm_1.nctag[yparm_1.ncoup - 1] = itmp1;
/*< NCSEG( NCOUP)= ITMP2 >*/
yparm_1.ncseg[yparm_1.ncoup - 1] = itmp2;
/*< IF( ITMP4.EQ.0) GOTO 14 >*/
if (itmp4 == 0) {
goto L14;
}
/*< NCOUP= NCOUP+1 >*/
++yparm_1.ncoup;
/*< IF( NCOUP.GT.5) GOTO 312 >*/
if (yparm_1.ncoup > 5) {
goto L312;
}
/*< NCTAG( NCOUP)= ITMP3 >*/
yparm_1.nctag[yparm_1.ncoup - 1] = itmp3;
/*< NCSEG( NCOUP)= ITMP4 >*/
yparm_1.ncseg[yparm_1.ncoup - 1] = itmp4;
/*< GOTO 14 >*/
goto L14;
/*< 312 WRITE( 6,313) >*/
L312:
s_wsfe(&io___73);
e_wsfe();
/* LOADING PARAMETERS */
/*< STOP >*/
s_stop("", 0L);
/*< 17 IF( IFLOW.EQ.3) GOTO 18 >*/
L17:
if (iflow == 3) {
goto L18;
}
/*< NLOAD=0 >*/
zload_1.nload = 0;
/*< IFLOW=3 >*/
iflow = 3;
/*< IF( IGO.GT.2) IGO=2 >*/
if (igo > 2) {
igo = 2;
}
/*< IF( ITMP1.EQ.(-1)) GOTO 14 >*/
if (itmp1 == -1) {
goto L14;
}
/*< 18 NLOAD= NLOAD+1 >*/
L18:
++zload_1.nload;
/*< IF( NLOAD.LE. LOADMX) GOTO 19 >*/
if (zload_1.nload <= loadmx) {
goto L19;
}
/*< WRITE( 6,139) >*/
s_wsfe(&io___74);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 19 LDTYP( NLOAD)= ITMP1 >*/
L19:
ldtyp[zload_1.nload - 1] = itmp1;
/*< LDTAG( NLOAD)= ITMP2 >*/
ldtag[zload_1.nload - 1] = itmp2;
/*< IF( ITMP4.EQ.0) ITMP4= ITMP3 >*/
if (itmp4 == 0) {
itmp4 = itmp3;
}
/*< LDTAGF( NLOAD)= ITMP3 >*/
ldtagf[zload_1.nload - 1] = itmp3;
/*< LDTAGT( NLOAD)= ITMP4 >*/
ldtagt[zload_1.nload - 1] = itmp4;
/*< IF( ITMP4.GE. ITMP3) GOTO 20 >*/
if (itmp4 >= itmp3) {
goto L20;
}
/*< WRITE( 6,140) NLOAD, ITMP3, ITMP4 >*/
s_wsfe(&io___79);
do_fio(&c__1, (char *)&zload_1.nload, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itmp3, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 20 ZLR( NLOAD)= TMP1 >*/
L20:
zlr[zload_1.nload - 1] = tmp1;
/*< ZLI( NLOAD)= TMP2 >*/
zli[zload_1.nload - 1] = tmp2;
/*< ZLC( NLOAD)= TMP3 >*/
zlc[zload_1.nload - 1] = tmp3;
/* GROUND PARAMETERS UNDER THE ANTENNA */
/*< GOTO 14 >*/
goto L14;
/*< 21 IFLOW=4 >*/
L21:
iflow = 4;
/*< IF( ICASX.EQ.0) GOTO 10 >*/
if (matpar_1.icasx == 0) {
goto L10;
}
/*< WRITE( 6,303) AIN >*/
s_wsfe(&io___83);
do_fio(&c__1, ain, 2L);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 10 IF( IGO.GT.2) IGO=2 >*/
L10:
if (igo > 2) {
igo = 2;
}
/*< IF( ITMP1.NE.(-1)) GOTO 22 >*/
if (itmp1 != -1) {
goto L22;
}
/*< KSYMP=1 >*/
gnd_1.ksymp = 1;
/*< NRADL=0 >*/
gnd_1.nradl = 0;
/*< IPERF=0 >*/
gnd_1.iperf = 0;
/*< GOTO 14 >*/
goto L14;
/*< 22 IPERF= ITMP1 >*/
L22:
gnd_1.iperf = itmp1;
/*< NRADL= ITMP2 >*/
gnd_1.nradl = itmp2;
/*< KSYMP=2 >*/
gnd_1.ksymp = 2;
/*< EPSR= TMP1 >*/
save_1.epsr = tmp1;
/*< SIG= TMP2 >*/
save_1.sig = tmp2;
/*< IF( NRADL.EQ.0) GOTO 23 >*/
if (gnd_1.nradl == 0) {
goto L23;
}
/*< IF( IPERF.NE.2) GOTO 314 >*/
if (gnd_1.iperf != 2) {
goto L314;
}
/*< WRITE( 6,390) >*/
s_wsfe(&io___84);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 314 SCRWLT= TMP3 >*/
L314:
save_1.scrwlt = tmp3;
/*< SCRWRT= TMP4 >*/
save_1.scrwrt = tmp4;
/*< GOTO 14 >*/
goto L14;
/*< 23 EPSR2= TMP3 >*/
L23:
fpat_1.epsr2 = tmp3;
/*< SIG2= TMP4 >*/
fpat_1.sig2 = tmp4;
/*< CLT= TMP5 >*/
fpat_1.clt = tmp5;
/*< CHT= TMP6 >*/
fpat_1.cht = tmp6;
/* EXCITATION PARAMETERS */
/*< GOTO 14 >*/
goto L14;
/*< 24 IF( IFLOW.EQ.5) GOTO 25 >*/
L24:
if (iflow == 5) {
goto L25;
}
/*< NSANT=0 >*/
vsorc_1.nsant = 0;
/*< NVQD=0 >*/
vsorc_1.nvqd = 0;
/*< IPED=0 >*/
iped = 0;
/*< IFLOW=5 >*/
iflow = 5;
/*< IF( IGO.GT.3) IGO=3 >*/
if (igo > 3) {
igo = 3;
}
/*< 25 MASYM= ITMP4/10 >*/
L25:
netcx_1.masym = itmp4 / 10;
/*< IF( ITMP1.GT.0.AND. ITMP1.NE.5) GOTO 27 >*/
if (itmp1 > 0 && itmp1 != 5) {
goto L27;
}
/*< IXTYP= ITMP1 >*/
fpat_1.ixtyp = itmp1;
/*< NTSOL=0 >*/
netcx_1.ntsol = 0;
/*< IF( IXTYP.EQ.0) GOTO 205 >*/
if (fpat_1.ixtyp == 0) {
goto L205;
}
/*< NVQD= NVQD+1 >*/
++vsorc_1.nvqd;
/*< IF( NVQD.GT. NSMAX) GOTO 206 >*/
if (vsorc_1.nvqd > nsmax) {
goto L206;
}
/*< IVQD( NVQD)= ISEGNO( ITMP2, ITMP3) >*/
vsorc_1.ivqd[vsorc_1.nvqd - 1] = isegno_(&itmp2, &itmp3);
/*< VQD( NVQD)= CMPLX( TMP1, TMP2) >*/
i__2 = vsorc_1.nvqd - 1;
z__1.r = tmp1, z__1.i = tmp2;
vsorc_1.vqd[i__2].r = z__1.r, vsorc_1.vqd[i__2].i = z__1.i;
/*< IF( ABS( VQD( NVQD)).LT.1.D-20) VQD( NVQD)=(1.,0.) >*/
if (z_abs(&vsorc_1.vqd[vsorc_1.nvqd - 1]) < 1e-20) {
i__2 = vsorc_1.nvqd - 1;
vsorc_1.vqd[i__2].r = 1., vsorc_1.vqd[i__2].i = 0.;
}
/*< GOTO 207 >*/
goto L207;
/*< 205 NSANT= NSANT+1 >*/
L205:
++vsorc_1.nsant;
/*< IF( NSANT.LE. NSMAX) GOTO 26 >*/
if (vsorc_1.nsant <= nsmax) {
goto L26;
}
/*< 206 WRITE( 6,141) >*/
L206:
s_wsfe(&io___85);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 26 ISANT( NSANT)= ISEGNO( ITMP2, ITMP3) >*/
L26:
vsorc_1.isant[vsorc_1.nsant - 1] = isegno_(&itmp2, &itmp3);
/*< VSANT( NSANT)= CMPLX( TMP1, TMP2) >*/
i__2 = vsorc_1.nsant - 1;
z__1.r = tmp1, z__1.i = tmp2;
vsorc_1.vsant[i__2].r = z__1.r, vsorc_1.vsant[i__2].i = z__1.i;
/*< IF( ABS( VSANT( NSANT)).LT.1.D-20) VSANT( NSANT)=(1.,0.) >*/
if (z_abs(&vsorc_1.vsant[vsorc_1.nsant - 1]) < 1e-20) {
i__2 = vsorc_1.nsant - 1;
vsorc_1.vsant[i__2].r = 1., vsorc_1.vsant[i__2].i = 0.;
}
/*< 207 IPED= ITMP4- MASYM*10 >*/
L207:
iped = itmp4 - netcx_1.masym * 10;
/*< ZPNORM= TMP3 >*/
zpnorm = tmp3;
/*< IF( IPED.EQ.1.AND. ZPNORM.GT.0) IPED=2 >*/
if (iped == 1 && zpnorm > 0.) {
iped = 2;
}
/*< GOTO 14 >*/
goto L14;
/*< 27 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) NTSOL=0 >*/
L27:
if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
netcx_1.ntsol = 0;
}
/*< IXTYP= ITMP1 >*/
fpat_1.ixtyp = itmp1;
/*< NTHI= ITMP2 >*/
nthi = itmp2;
/*< NPHI= ITMP3 >*/
nphi = itmp3;
/*< XPR1= TMP1 >*/
xpr1 = tmp1;
/*< XPR2= TMP2 >*/
xpr2 = tmp2;
/*< XPR3= TMP3 >*/
xpr3 = tmp3;
/*< XPR4= TMP4 >*/
xpr4 = tmp4;
/*< XPR5= TMP5 >*/
xpr5 = tmp5;
/*< XPR6= TMP6 >*/
fpat_1.xpr6 = tmp6;
/*< NSANT=0 >*/
vsorc_1.nsant = 0;
/*< NVQD=0 >*/
vsorc_1.nvqd = 0;
/*< THETIS= XPR1 >*/
thetis = xpr1;
/*< PHISS= XPR2 >*/
phiss = xpr2;
/* NETWORK PARAMETERS */
/*< GOTO 14 >*/
goto L14;
/*< 28 IF( IFLOW.EQ.6) GOTO 29 >*/
L28:
if (iflow == 6) {
goto L29;
}
/*< NONET=0 >*/
netcx_1.nonet = 0;
/*< NTSOL=0 >*/
netcx_1.ntsol = 0;
/*< IFLOW=6 >*/
iflow = 6;
/*< IF( IGO.GT.3) IGO=3 >*/
if (igo > 3) {
igo = 3;
}
/*< IF( ITMP2.EQ.(-1)) GOTO 14 >*/
if (itmp2 == -1) {
goto L14;
}
/*< 29 NONET= NONET+1 >*/
L29:
++netcx_1.nonet;
/*< IF( NONET.LE. NETMX) GOTO 30 >*/
if (netcx_1.nonet <= netmx) {
goto L30;
}
/*< WRITE( 6,142) >*/
s_wsfe(&io___95);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 30 NTYP( NONET)=2 >*/
L30:
netcx_1.ntyp[netcx_1.nonet - 1] = 2;
/*< IF( AIN.EQ. ATST(6)) NTYP( NONET)=1 >*/
if (s_cmp(ain, atst + 10, 2L, 2L) == 0) {
netcx_1.ntyp[netcx_1.nonet - 1] = 1;
}
/*< ISEG1( NONET)= ISEGNO( ITMP1, ITMP2) >*/
netcx_1.iseg1[netcx_1.nonet - 1] = isegno_(&itmp1, &itmp2);
/*< ISEG2( NONET)= ISEGNO( ITMP3, ITMP4) >*/
netcx_1.iseg2[netcx_1.nonet - 1] = isegno_(&itmp3, &itmp4);
/*< X11R( NONET)= TMP1 >*/
netcx_1.x11r[netcx_1.nonet - 1] = tmp1;
/*< X11I( NONET)= TMP2 >*/
netcx_1.x11i[netcx_1.nonet - 1] = tmp2;
/*< X12R( NONET)= TMP3 >*/
netcx_1.x12r[netcx_1.nonet - 1] = tmp3;
/*< X12I( NONET)= TMP4 >*/
netcx_1.x12i[netcx_1.nonet - 1] = tmp4;
/*< X22R( NONET)= TMP5 >*/
netcx_1.x22r[netcx_1.nonet - 1] = tmp5;
/*< X22I( NONET)= TMP6 >*/
netcx_1.x22i[netcx_1.nonet - 1] = tmp6;
/*< IF( NTYP( NONET).EQ.1.OR. TMP1.GT.0.) GOTO 14 >*/
if (netcx_1.ntyp[netcx_1.nonet - 1] == 1 || tmp1 > 0.) {
goto L14;
}
/*< NTYP( NONET)=3 >*/
netcx_1.ntyp[netcx_1.nonet - 1] = 3;
/* *** */
/* PLOT FLAGS */
/*< X11R( NONET)=- TMP1 >*/
netcx_1.x11r[netcx_1.nonet - 1] = -tmp1;
/*< 330 IPLP1= ITMP1 >*/
L330:
plot_1.iplp1 = itmp1;
/*< IPLP2= ITMP2 >*/
plot_1.iplp2 = itmp2;
/*< IPLP3= ITMP3 >*/
plot_1.iplp3 = itmp3;
/* *** */
/*< IPLP4= ITMP4 >*/
plot_1.iplp4 = itmp4;
/* PRINT CONTROL FOR CURRENT */
/*< GOTO 14 >*/
goto L14;
/*< 31 IPTFLG= ITMP1 >*/
L31:
iptflg = itmp1;
/*< IPTAG= ITMP2 >*/
iptag = itmp2;
/*< IPTAGF= ITMP3 >*/
iptagf = itmp3;
/*< IPTAGT= ITMP4 >*/
iptagt = itmp4;
/*< IF( ITMP3.EQ.0.AND. IPTFLG.NE.-1) IPTFLG=-2 >*/
if (itmp3 == 0 && iptflg != -1) {
iptflg = -2;
}
/*< IF( ITMP4.EQ.0) IPTAGT= IPTAGF >*/
if (itmp4 == 0) {
iptagt = iptagf;
}
/* WRITE CONTROL FOR CHARGE */
/*< GOTO 14 >*/
goto L14;
/*< 319 IPTFLQ= ITMP1 >*/
L319:
iptflq = itmp1;
/*< IPTAQ= ITMP2 >*/
iptaq = itmp2;
/*< IPTAQF= ITMP3 >*/
iptaqf = itmp3;
/*< IPTAQT= ITMP4 >*/
iptaqt = itmp4;
/*< IF( ITMP3.EQ.0.AND. IPTFLQ.NE.-1) IPTFLQ=-2 >*/
if (itmp3 == 0 && iptflq != -1) {
iptflq = -2;
}
/*< IF( ITMP4.EQ.0) IPTAQT= IPTAQF >*/
if (itmp4 == 0) {
iptaqt = iptaqf;
}
/* NEAR FIELD CALCULATION PARAMETERS */
/*< GOTO 14 >*/
goto L14;
/*< 208 NFEH=1 >*/
L208:
fpat_1.nfeh = 1;
/*< GOTO 209 >*/
goto L209;
/*< 32 NFEH=0 >*/
L32:
fpat_1.nfeh = 0;
/*< 209 IF(.NOT.( IFLOW.EQ.8.AND. NFRQ.NE.1)) GOTO 33 >*/
L209:
if (! (iflow == 8 && nfrq != 1)) {
goto L33;
}
/*< WRITE( 6,143) >*/
s_wsfe(&io___102);
e_wsfe();
/*< 33 NEAR= ITMP1 >*/
L33:
fpat_1.near = itmp1;
/*< NRX= ITMP2 >*/
fpat_1.nrx = itmp2;
/*< NRY= ITMP3 >*/
fpat_1.nry = itmp3;
/*< NRZ= ITMP4 >*/
fpat_1.nrz = itmp4;
/*< XNR= TMP1 >*/
fpat_1.xnr = tmp1;
/*< YNR= TMP2 >*/
fpat_1.ynr = tmp2;
/*< ZNR= TMP3 >*/
fpat_1.znr = tmp3;
/*< DXNR= TMP4 >*/
fpat_1.dxnr = tmp4;
/*< DYNR= TMP5 >*/
fpat_1.dynr = tmp5;
/*< DZNR= TMP6 >*/
fpat_1.dznr = tmp6;
/*< IFLOW=8 >*/
iflow = 8;
/*< IF( NFRQ.NE.1) GOTO 14 >*/
if (nfrq != 1) {
goto L14;
}
/* GROUND REPRESENTATION */
/*< GOTO (41,46,53,71,72), IGO >*/
switch ((int)igo) {
case 1: goto L41;
case 2: goto L46;
case 3: goto L53;
case 4: goto L71;
case 5: goto L72;
}
/*< 34 EPSR2= TMP1 >*/
L34:
fpat_1.epsr2 = tmp1;
/*< SIG2= TMP2 >*/
fpat_1.sig2 = tmp2;
/*< CLT= TMP3 >*/
fpat_1.clt = tmp3;
/*< CHT= TMP4 >*/
fpat_1.cht = tmp4;
/*< IFLOW=9 >*/
iflow = 9;
/* STANDARD OBSERVATION ANGLE PARAMETERS */
/*< GOTO 14 >*/
goto L14;
/*< 36 IFAR= ITMP1 >*/
L36:
gnd_1.ifar = itmp1;
/*< NTH= ITMP2 >*/
fpat_1.nth = itmp2;
/*< NPH= ITMP3 >*/
fpat_1.nph = itmp3;
/*< IF( NTH.EQ.0) NTH=1 >*/
if (fpat_1.nth == 0) {
fpat_1.nth = 1;
}
/*< IF( NPH.EQ.0) NPH=1 >*/
if (fpat_1.nph == 0) {
fpat_1.nph = 1;
}
/*< IPD= ITMP4/10 >*/
fpat_1.ipd = itmp4 / 10;
/*< IAVP= ITMP4- IPD*10 >*/
fpat_1.iavp = itmp4 - fpat_1.ipd * 10;
/*< INOR= IPD/10 >*/
fpat_1.inor = fpat_1.ipd / 10;
/*< IPD= IPD- INOR*10 >*/
fpat_1.ipd -= fpat_1.inor * 10;
/*< IAX= INOR/10 >*/
fpat_1.iax = fpat_1.inor / 10;
/*< INOR= INOR- IAX*10 >*/
fpat_1.inor -= fpat_1.iax * 10;
/*< IF( IAX.NE.0) IAX=1 >*/
if (fpat_1.iax != 0) {
fpat_1.iax = 1;
}
/*< IF( IPD.NE.0) IPD=1 >*/
if (fpat_1.ipd != 0) {
fpat_1.ipd = 1;
}
/*< IF( NTH.LT.2.OR. NPH.LT.2) IAVP=0 >*/
if (fpat_1.nth < 2 || fpat_1.nph < 2) {
fpat_1.iavp = 0;
}
/*< IF( IFAR.EQ.1) IAVP=0 >*/
if (gnd_1.ifar == 1) {
fpat_1.iavp = 0;
}
/*< THETS= TMP1 >*/
fpat_1.thets = tmp1;
/*< PHIS= TMP2 >*/
fpat_1.phis = tmp2;
/*< DTH= TMP3 >*/
fpat_1.dth = tmp3;
/*< DPH= TMP4 >*/
fpat_1.dph = tmp4;
/*< RFLD= TMP5 >*/
fpat_1.rfld = tmp5;
/*< GNOR= TMP6 >*/
fpat_1.gnor = tmp6;
/*< IFLOW=10 >*/
iflow = 10;
/* WRITE NUMERICAL GREEN'S FUNCTION TAPE */
/*< GOTO (41,46,53,71,78), IGO >*/
switch ((int)igo) {
case 1: goto L41;
case 2: goto L46;
case 3: goto L53;
case 4: goto L71;
case 5: goto L78;
}
/*< 322 IFLOW=12 >*/
L322:
iflow = 12;
/*< IF( ICASX.EQ.0) GOTO 301 >*/
if (matpar_1.icasx == 0) {
goto L301;
}
/*< WRITE( 6,302) >*/
s_wsfe(&io___103);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 301 IRNGF= IRESRV/2 >*/
L301:
irngf = iresrv / 2;
/* EXECUTE CARD - CALC. INCLUDING RADIATED FIELDS */
/*< GOTO (41,46,52,52,52), IGO >*/
switch ((int)igo) {
case 1: goto L41;
case 2: goto L46;
case 3: goto L52;
case 4: goto L52;
case 5: goto L52;
}
/*< 37 IF( IFLOW.EQ.10.AND. ITMP1.EQ.0) GOTO 14 >*/
L37:
if (iflow == 10 && itmp1 == 0) {
goto L14;
}
/*< IF( NFRQ.EQ.1.AND. ITMP1.EQ.0.AND. IFLOW.GT.7) GOTO 14 >*/
if (nfrq == 1 && itmp1 == 0 && iflow > 7) {
goto L14;
}
/*< IF( ITMP1.NE.0) GOTO 39 >*/
if (itmp1 != 0) {
goto L39;
}
/*< IF( IFLOW.GT.7) GOTO 38 >*/
if (iflow > 7) {
goto L38;
}
/*< IFLOW=7 >*/
iflow = 7;
/*< GOTO 40 >*/
goto L40;
/*< 38 IFLOW=11 >*/
L38:
iflow = 11;
/*< GOTO 40 >*/
goto L40;
/*< 39 IFAR=0 >*/
L39:
gnd_1.ifar = 0;
/*< RFLD=0. >*/
fpat_1.rfld = 0.;
/*< IPD=0 >*/
fpat_1.ipd = 0;
/*< IAVP=0 >*/
fpat_1.iavp = 0;
/*< INOR=0 >*/
fpat_1.inor = 0;
/*< IAX=0 >*/
fpat_1.iax = 0;
/*< NTH=91 >*/
fpat_1.nth = 91;
/*< NPH=1 >*/
fpat_1.nph = 1;
/*< THETS=0. >*/
fpat_1.thets = 0.;
/*< PHIS=0. >*/
fpat_1.phis = 0.;
/*< DTH=1.0 >*/
fpat_1.dth = 1.;
/*< DPH=0. >*/
fpat_1.dph = 0.;
/*< IF( ITMP1.EQ.2) PHIS=90. >*/
if (itmp1 == 2) {
fpat_1.phis = 90.;
}
/*< IF( ITMP1.NE.3) GOTO 40 >*/
if (itmp1 != 3) {
goto L40;
}
/*< NPH=2 >*/
fpat_1.nph = 2;
/*< DPH=90. >*/
fpat_1.dph = 90.;
/* END OF THE MAIN INPUT SECTION */
/* BEGINNING OF THE FREQUENCY DO LOOP */
/*< 40 GOTO (41,46,53,71,78), IGO >*/
L40:
switch ((int)igo) {
case 1: goto L41;
case 2: goto L46;
case 3: goto L53;
case 4: goto L71;
case 5: goto L78;
}
/* *** */
/*< 41 MHZ=1 >*/
L41:
mhz = 1;
/*< IF( N.EQ.0.OR. IFRTMW.EQ.1) GOTO 406 >*/
if (data_1.n == 0 || ifrtmw == 1) {
goto L406;
}
/*< IFRTMW=1 >*/
ifrtmw = 1;
/*< DO 445 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< XTEMP( I)= X( I) >*/
xtemp[i - 1] = data_1.x[i - 1];
/*< YTEMP( I)= Y( I) >*/
ytemp[i - 1] = data_1.y[i - 1];
/*< ZTEMP( I)= Z( I) >*/
ztemp[i - 1] = data_1.z[i - 1];
/*< SITEMP( I)= SI( I) >*/
sitemp[i - 1] = data_1.si[i - 1];
/*< BITEMP( I)= BI( I) >*/
bitemp[i - 1] = data_1.bi[i - 1];
/*< 445 CONTINUE >*/
/* L445: */
}
/*< 406 IF( M.EQ.0.OR. IFRTMP.EQ.1) GOTO 407 >*/
L406:
if (data_1.m == 0 || ifrtmp == 1) {
goto L407;
}
/*< IFRTMP=1 >*/
ifrtmp = 1;
/*< J= LD+1 >*/
j = data_1.ld + 1;
/*< DO 545 I=1, M >*/
i__2 = data_1.m;
for (i = 1; i <= i__2; ++i) {
/*< J= J-1 >*/
--j;
/*< XTEMP( J)= X( J) >*/
xtemp[j - 1] = data_1.x[j - 1];
/*< YTEMP( J)= Y( J) >*/
ytemp[j - 1] = data_1.y[j - 1];
/*< ZTEMP( J)= Z( J) >*/
ztemp[j - 1] = data_1.z[j - 1];
/*< BITEMP( J)= BI( J) >*/
bitemp[j - 1] = data_1.bi[j - 1];
/*< 545 CONTINUE >*/
/* L545: */
}
/*< 407 CONTINUE >*/
L407:
/* *** */
/* CORE ALLOCATION FOR PRIMARY INTERACTON MATRIX. (A) */
/*< FMHZ1= FMHZ >*/
fmhz1 = save_1.fmhz;
/*< IF( IMAT.EQ.0) CALL FBLOCK( NPEQ, NEQ, IRESRV, IRNGF, IPSYM) >*/
if (matpar_1.imat == 0) {
fblock_(&netcx_1.npeq, &netcx_1.neq, &iresrv, &irngf, &data_1.ipsym);
}
/*< 42 IF( MHZ.EQ.1) GOTO 44 >*/
L42:
if (mhz == 1) {
goto L44;
}
/* FMHZ=FMHZ+DELFRQ */
/* *** */
/*< IF( IFRQ.EQ.1) GOTO 43 >*/
if (ifrq == 1) {
goto L43;
}
/*< FMHZ= FMHZ1+( MHZ-1)* DELFRQ >*/
save_1.fmhz = fmhz1 + (mhz - 1) * delfrq;
/*< GOTO 44 >*/
goto L44;
/*< 43 FMHZ= FMHZ* DELFRQ >*/
L43:
save_1.fmhz *= delfrq;
/* *** */
/*< 44 FR= FMHZ/ CVEL >*/
L44:
fr = save_1.fmhz / cvel;
/*< WLAM= CVEL/ FMHZ >*/
data_1.wlam = cvel / save_1.fmhz;
/*< WRITE( 6,145) FMHZ, WLAM >*/
s_wsfe(&io___113);
do_fio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< WRITE( 6,196) RKH >*/
s_wsfe(&io___114);
do_fio(&c__1, (char *)&rkh, (ftnlen)sizeof(doublereal));
e_wsfe();
/* FREQUENCY SCALING OF GEOMETRIC PARAMETERS */
/* *** FMHZS=FMHZ */
/*< IF( IEXK.EQ.1) WRITE( 6,321) >*/
if (iexk == 1) {
s_wsfe(&io___115);
e_wsfe();
}
/*< IF( N.EQ.0) GOTO 306 >*/
if (data_1.n == 0) {
goto L306;
}
/* *** */
/*< DO 45 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< X( I)= XTEMP( I)* FR >*/
data_1.x[i - 1] = xtemp[i - 1] * fr;
/*< Y( I)= YTEMP( I)* FR >*/
data_1.y[i - 1] = ytemp[i - 1] * fr;
/*< Z( I)= ZTEMP( I)* FR >*/
data_1.z[i - 1] = ztemp[i - 1] * fr;
/*< SI( I)= SITEMP( I)* FR >*/
data_1.si[i - 1] = sitemp[i - 1] * fr;
/* *** */
/*< 45 BI( I)= BITEMP( I)* FR >*/
/* L45: */
data_1.bi[i - 1] = bitemp[i - 1] * fr;
}
/*< 306 IF( M.EQ.0) GOTO 307 >*/
L306:
if (data_1.m == 0) {
goto L307;
}
/*< FR2= FR* FR >*/
fr2 = fr * fr;
/*< J= LD+1 >*/
j = data_1.ld + 1;
/*< DO 245 I=1, M >*/
i__2 = data_1.m;
for (i = 1; i <= i__2; ++i) {
/* *** */
/*< J= J-1 >*/
--j;
/*< X( J)= XTEMP( J)* FR >*/
data_1.x[j - 1] = xtemp[j - 1] * fr;
/*< Y( J)= YTEMP( J)* FR >*/
data_1.y[j - 1] = ytemp[j - 1] * fr;
/*< Z( J)= ZTEMP( J)* FR >*/
data_1.z[j - 1] = ztemp[j - 1] * fr;
/* *** */
/*< 245 BI( J)= BITEMP( J)* FR2 >*/
/* L245: */
data_1.bi[j - 1] = bitemp[j - 1] * fr2;
}
/* STRUCTURE SEGMENT LOADING */
/*< 307 IGO=2 >*/
L307:
igo = 2;
/*< 46 WRITE( 6,146) >*/
L46:
s_wsfe(&io___117);
e_wsfe();
/*< >*/
if (zload_1.nload != 0) {
load_(ldtyp, ldtag, ldtagf, ldtagt, zlr, zli, zlc);
}
/*< IF( NLOAD.EQ.0.AND. NLODF.EQ.0) WRITE( 6,147) >*/
if (zload_1.nload == 0 && zload_1.nlodf == 0) {
s_wsfe(&io___118);
e_wsfe();
}
/* GROUND PARAMETER */
/*< IF( NLOAD.EQ.0.AND. NLODF.NE.0) WRITE( 6,327) >*/
if (zload_1.nload == 0 && zload_1.nlodf != 0) {
s_wsfe(&io___119);
e_wsfe();
}
/*< WRITE( 6,148) >*/
s_wsfe(&io___120);
e_wsfe();
/*< IF( KSYMP.EQ.1) GOTO 49 >*/
if (gnd_1.ksymp == 1) {
goto L49;
}
/*< FRATI=(1.,0.) >*/
gnd_1.frati.r = 1., gnd_1.frati.i = 0.;
/*< IF( IPERF.EQ.1) GOTO 48 >*/
if (gnd_1.iperf == 1) {
goto L48;
}
/*< IF( SIG.LT.0.) SIG=- SIG/(59.96* WLAM) >*/
if (save_1.sig < 0.) {
save_1.sig = -save_1.sig / (data_1.wlam * 59.96);
}
/*< EPSC= CMPLX( EPSR,- SIG* WLAM*59.96) >*/
d__2 = -save_1.sig * data_1.wlam;
d__1 = d__2 * 59.96;
z__1.r = save_1.epsr, z__1.i = d__1;
epsc.r = z__1.r, epsc.i = z__1.i;
/*< ZRATI=1./ SQRT( EPSC) >*/
z_sqrt(&z__2, &epsc);
z_div(&z__1, &c_b48, &z__2);
gnd_1.zrati.r = z__1.r, gnd_1.zrati.i = z__1.i;
/*< U= ZRATI >*/
gwav_1.u.r = gnd_1.zrati.r, gwav_1.u.i = gnd_1.zrati.i;
/*< U2= U* U >*/
z__1.r = gwav_1.u.r * gwav_1.u.r - gwav_1.u.i * gwav_1.u.i, z__1.i =
gwav_1.u.r * gwav_1.u.i + gwav_1.u.i * gwav_1.u.r;
gwav_1.u2.r = z__1.r, gwav_1.u2.i = z__1.i;
/*< IF( NRADL.EQ.0) GOTO 47 >*/
if (gnd_1.nradl == 0) {
goto L47;
}
/*< SCRWL= SCRWLT/ WLAM >*/
gnd_1.scrwl = save_1.scrwlt / data_1.wlam;
/*< SCRWR= SCRWRT/ WLAM >*/
gnd_1.scrwr = save_1.scrwrt / data_1.wlam;
/*< T1= FJ*2367.067D+0/ DFLOAT( NRADL) >*/
z__2.r = fj.r * 2367.067, z__2.i = fj.i * 2367.067;
d__1 = (doublereal) gnd_1.nradl;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
gnd_1.t1.r = z__1.r, gnd_1.t1.i = z__1.i;
/*< T2= SCRWR* DFLOAT( NRADL) >*/
gnd_1.t2 = gnd_1.scrwr * (doublereal) gnd_1.nradl;
/*< WRITE( 6,170) NRADL, SCRWLT, SCRWRT >*/
s_wsfe(&io___122);
do_fio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< WRITE( 6,149) >*/
s_wsfe(&io___123);
e_wsfe();
/*< 47 IF( IPERF.EQ.2) GOTO 328 >*/
L47:
if (gnd_1.iperf == 2) {
goto L328;
}
/*< WRITE( 6,391) >*/
s_wsfe(&io___124);
e_wsfe();
/*< GOTO 329 >*/
goto L329;
/*< >*/
L328:
if (ggrid_1.nxa[0] == 0) {
s_rsue(&io___125);
do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
e_rsue();
}
/*< FRATI=( EPSC-1.)/( EPSC+1.) >*/
z__2.r = epsc.r - 1., z__2.i = epsc.i;
z__3.r = epsc.r + 1., z__3.i = epsc.i;
z_div(&z__1, &z__2, &z__3);
gnd_1.frati.r = z__1.r, gnd_1.frati.i = z__1.i;
/*< IF( ABS(( EPSCF- EPSC)/ EPSC).LT.1.D-3) GOTO 400 >*/
z__2.r = ggrid_1.epscf.r - epsc.r, z__2.i = ggrid_1.epscf.i - epsc.i;
z_div(&z__1, &z__2, &epsc);
if (z_abs(&z__1) < .001) {
goto L400;
}
/*< WRITE( 6,393) EPSCF, EPSC >*/
s_wsfe(&io___126);
do_fio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&epsc, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 400 WRITE( 6,392) >*/
L400:
s_wsfe(&io___127);
e_wsfe();
/*< 329 WRITE( 6,150) EPSR, SIG, EPSC >*/
L329:
s_wsfe(&io___128);
do_fio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&epsc, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 50 >*/
goto L50;
/*< 48 WRITE( 6,151) >*/
L48:
s_wsfe(&io___129);
e_wsfe();
/*< GOTO 50 >*/
goto L50;
/*< 49 WRITE( 6,152) >*/
L49:
s_wsfe(&io___130);
e_wsfe();
/* * * * */
/* FILL AND FACTOR PRIMARY INTERACTION MATRIX */
/*< 50 CONTINUE >*/
L50:
/*< CALL SECNDS( TIM1) >*/
secnds_(&tim1);
/*< IF( ICASX.NE.0) GOTO 324 >*/
if (matpar_1.icasx != 0) {
goto L324;
}
/*< CALL CMSET( NEQ, CM, RKH, IEXK) >*/
cmset_(&netcx_1.neq, cmb_1.cm, &rkh, &iexk);
/*< CALL SECNDS( TIM2) >*/
secnds_(&tim2);
/*< TIM= TIM2- TIM1 >*/
tim = tim2 - tim1;
/*< CALL FACTRS( NPEQ, NEQ, CM, IP, IX,11,12,13,14) >*/
factrs_(&netcx_1.npeq, &netcx_1.neq, cmb_1.cm, save_1.ip, ix, &c__11, &
c__12, &c__13, &c__14);
/* N.G.F. - FILL B, C, AND D AND FACTOR D-C(INV(A)B) */
/* **** */
/*< GOTO 323 >*/
goto L323;
/* **** */
/*< 324 IF( NEQ2.EQ.0) GOTO 333 >*/
L324:
if (netcx_1.neq2 == 0) {
goto L333;
}
/*< >*/
cmngf_(&cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11 - 1], &
matpar_1.npbx, &netcx_1.neq, &netcx_1.neq2, &rkh, &iexk);
/*< CALL SECNDS( TIM2) >*/
secnds_(&tim2);
/*< TIM= TIM2- TIM1 >*/
tim = tim2 - tim1;
/*< >*/
facgf_(cmb_1.cm, &cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11
- 1], &cmb_1.cm[ix11 - 1], save_1.ip, ix, &data_1.np, &data_1.n1,
&data_1.mp, &data_1.m1, &netcx_1.neq, &netcx_1.neq2);
/*< 323 CALL SECNDS( TIM1) >*/
L323:
secnds_(&tim1);
/*< TIM2= TIM1- TIM2 >*/
tim2 = tim1 - tim2;
/*< WRITE( 6,153) TIM, TIM2 >*/
s_wsfe(&io___135);
do_fio(&c__1, (char *)&tim, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tim2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 333 IGO=3 >*/
L333:
igo = 3;
/*< NTSOL=0 >*/
netcx_1.ntsol = 0;
/* WRITE N.G.F. FILE */
/*< IF( IFLOW.NE.12) GOTO 53 >*/
if (iflow != 12) {
goto L53;
}
/*< 52 CALL GFOUT >*/
L52:
gfout_();
/* EXCITATION SET UP (RIGHT HAND SIDE, -E INC.) */
/*< GOTO 14 >*/
goto L14;
/*< 53 NTHIC=1 >*/
L53:
nthic = 1;
/*< NPHIC=1 >*/
nphic = 1;
/*< INC=1 >*/
inc = 1;
/*< NPRINT=0 >*/
netcx_1.nprint = 0;
/*< 54 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 56 >*/
L54:
if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
goto L56;
}
/*< IF( IPTFLG.LE.0.OR. IXTYP.EQ.4) WRITE( 6,154) >*/
if (iptflg <= 0 || fpat_1.ixtyp == 4) {
s_wsfe(&io___139);
e_wsfe();
}
/*< TMP5= TA* XPR5 >*/
tmp5 = ta * xpr5;
/*< TMP4= TA* XPR4 >*/
tmp4 = ta * xpr4;
/*< IF( IXTYP.NE.4) GOTO 55 >*/
if (fpat_1.ixtyp != 4) {
goto L55;
}
/*< TMP1= XPR1/ WLAM >*/
tmp1 = xpr1 / data_1.wlam;
/*< TMP2= XPR2/ WLAM >*/
tmp2 = xpr2 / data_1.wlam;
/*< TMP3= XPR3/ WLAM >*/
tmp3 = xpr3 / data_1.wlam;
/*< TMP6= XPR6/( WLAM* WLAM) >*/
tmp6 = fpat_1.xpr6 / (data_1.wlam * data_1.wlam);
/*< WRITE( 6,156) XPR1, XPR2, XPR3, XPR4, XPR5, XPR6 >*/
s_wsfe(&io___140);
do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr5, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 56 >*/
goto L56;
/*< 55 TMP1= TA* XPR1 >*/
L55:
tmp1 = ta * xpr1;
/*< TMP2= TA* XPR2 >*/
tmp2 = ta * xpr2;
/*< TMP3= TA* XPR3 >*/
tmp3 = ta * xpr3;
/*< TMP6= XPR6 >*/
tmp6 = fpat_1.xpr6;
/*< >*/
if (iptflg <= 0) {
s_wsfe(&io___141);
do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* MATRIX SOLVING (NETWK CALLS SOLVES) */
/*< 56 CALL ETMNS( TMP1, TMP2, TMP3, TMP4, TMP5, TMP6, IXTYP, CUR) >*/
L56:
etmns_(&tmp1, &tmp2, &tmp3, &tmp4, &tmp5, &tmp6, &fpat_1.ixtyp,
crnt_1.cur);
/*< IF( NONET.EQ.0.OR. INC.GT.1) GOTO 60 >*/
if (netcx_1.nonet == 0 || inc > 1) {
goto L60;
}
/*< WRITE( 6,158) >*/
s_wsfe(&io___142);
e_wsfe();
/*< ITMP3=0 >*/
itmp3 = 0;
/*< ITMP1= NTYP(1) >*/
itmp1 = netcx_1.ntyp[0];
/*< DO 59 I=1,2 >*/
for (i = 1; i <= 2; ++i) {
/*< IF( ITMP1.EQ.3) ITMP1=2 >*/
if (itmp1 == 3) {
itmp1 = 2;
}
/*< IF( ITMP1.EQ.2) WRITE( 6,159) >*/
if (itmp1 == 2) {
s_wsfe(&io___143);
e_wsfe();
}
/*< IF( ITMP1.EQ.1) WRITE( 6,160) >*/
if (itmp1 == 1) {
s_wsfe(&io___144);
e_wsfe();
}
/*< DO 58 J=1, NONET >*/
i__2 = netcx_1.nonet;
for (j = 1; j <= i__2; ++j) {
/*< ITMP2= NTYP( J) >*/
itmp2 = netcx_1.ntyp[j - 1];
/*< IF(( ITMP2/ ITMP1).EQ.1) GOTO 57 >*/
if (itmp2 / itmp1 == 1) {
goto L57;
}
/*< ITMP3= ITMP2 >*/
itmp3 = itmp2;
/*< GOTO 58 >*/
goto L58;
/*< 57 ITMP4= ISEG1( J) >*/
L57:
itmp4 = netcx_1.iseg1[j - 1];
/*< ITMP5= ISEG2( J) >*/
itmp5 = netcx_1.iseg2[j - 1];
/*< >*/
if (itmp2 >= 2 && netcx_1.x11i[j - 1] <= 0.) {
/* Computing 2nd power */
d__2 = data_1.x[itmp5 - 1] - data_1.x[itmp4 - 1];
/* Computing 2nd power */
d__3 = data_1.y[itmp5 - 1] - data_1.y[itmp4 - 1];
d__1 = d__2 * d__2 + d__3 * d__3;
/* Computing 2nd power */
d__4 = data_1.z[itmp5 - 1] - data_1.z[itmp4 - 1];
netcx_1.x11i[j - 1] = data_1.wlam * sqrt(d__1 + d__4 * d__4);
}
/*< >*/
s_wsfe(&io___146);
do_fio(&c__1, (char *)&data_1.itag[itmp4 - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itmp4, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.itag[itmp5 - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&itmp5, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&netcx_1.x11r[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&netcx_1.x11i[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&netcx_1.x12r[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&netcx_1.x12i[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&netcx_1.x22r[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, (char *)&netcx_1.x22i[j - 1], (ftnlen)sizeof(
doublereal));
do_fio(&c__1, pnet + ((itmp2 << 1) - 2) * 6, 6L);
do_fio(&c__1, pnet + ((itmp2 << 1) - 1) * 6, 6L);
e_wsfe();
/*< 58 CONTINUE >*/
L58:
;
}
/*< IF( ITMP3.EQ.0) GOTO 60 >*/
if (itmp3 == 0) {
goto L60;
}
/*< ITMP1= ITMP3 >*/
itmp1 = itmp3;
/*< 59 CONTINUE >*/
/* L59: */
}
/*< 60 CONTINUE >*/
L60:
/*< IF( INC.GT.1.AND. IPTFLG.GT.0) NPRINT=1 >*/
if (inc > 1 && iptflg > 0) {
netcx_1.nprint = 1;
}
/*< CALL NETWK( CM, CM( IB11), CM( IC11), CM( ID11), IP, CUR) >*/
netwk_(cmb_1.cm, &cmb_1.cm[ib11 - 1], &cmb_1.cm[ic11 - 1], &cmb_1.cm[id11
- 1], save_1.ip, crnt_1.cur);
/*< NTSOL=1 >*/
netcx_1.ntsol = 1;
/*< IF( IPED.EQ.0) GOTO 61 >*/
if (iped == 0) {
goto L61;
}
/*< ITMP1= MHZ+4*( MHZ-1) >*/
itmp1 = mhz + (mhz - 1 << 2);
/*< IF( ITMP1.GT.( NORMF-3)) GOTO 61 >*/
if (itmp1 > normf - 3) {
goto L61;
}
/*< FNORM( ITMP1)= REAL( ZPED) >*/
fnorm[itmp1 - 1] = netcx_1.zped.r;
/*< FNORM( ITMP1+1)= AIMAG( ZPED) >*/
fnorm[itmp1] = d_imag(&netcx_1.zped);
/*< FNORM( ITMP1+2)= ABS( ZPED) >*/
fnorm[itmp1 + 1] = z_abs(&netcx_1.zped);
/*< FNORM( ITMP1+3)= CANG( ZPED) >*/
fnorm[itmp1 + 2] = cang_(&netcx_1.zped);
/*< IF( IPED.EQ.2) GOTO 61 >*/
if (iped == 2) {
goto L61;
}
/*< IF( FNORM( ITMP1+2).GT. ZPNORM) ZPNORM= FNORM( ITMP1+2) >*/
if (fnorm[itmp1 + 1] > zpnorm) {
zpnorm = fnorm[itmp1 + 1];
}
/* PRINTING STRUCTURE CURRENTS */
/*< 61 CONTINUE >*/
L61:
/*< IF( N.EQ.0) GOTO 308 >*/
if (data_1.n == 0) {
goto L308;
}
/*< IF( IPTFLG.EQ.(-1)) GOTO 63 >*/
if (iptflg == -1) {
goto L63;
}
/*< IF( IPTFLG.GT.0) GOTO 62 >*/
if (iptflg > 0) {
goto L62;
}
/*< WRITE( 6,161) >*/
s_wsfe(&io___148);
e_wsfe();
/*< WRITE( 6,162) >*/
s_wsfe(&io___149);
e_wsfe();
/*< GOTO 63 >*/
goto L63;
/*< 62 IF( IPTFLG.EQ.3.OR. INC.GT.1) GOTO 63 >*/
L62:
if (iptflg == 3 || inc > 1) {
goto L63;
}
/*< WRITE( 6,163) XPR3, HPOL( IXTYP), XPR6 >*/
s_wsfe(&io___150);
do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 63 PLOSS=0. >*/
L63:
fpat_1.ploss = 0.;
/*< ITMP1=0 >*/
itmp1 = 0;
/*< JUMP= IPTFLG+1 >*/
jump = iptflg + 1;
/*< DO 69 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< CURI= CUR( I)* WLAM >*/
i__1 = i - 1;
z__1.r = data_1.wlam * crnt_1.cur[i__1].r, z__1.i = data_1.wlam *
crnt_1.cur[i__1].i;
curi.r = z__1.r, curi.i = z__1.i;
/*< CMAG= ABS( CURI) >*/
cmag = z_abs(&curi);
/*< PH= CANG( CURI) >*/
ph = cang_(&curi);
/*< IF( NLOAD.EQ.0.AND. NLODF.EQ.0) GOTO 64 >*/
if (zload_1.nload == 0 && zload_1.nlodf == 0) {
goto L64;
}
/*< IF( ABS( REAL( ZARRAY( I))).LT.1.D-20) GOTO 64 >*/
i__1 = i - 1;
if ((d__1 = zload_1.zarray[i__1].r, abs(d__1)) < 1e-20) {
goto L64;
}
/*< PLOSS= PLOSS+.5* CMAG* CMAG* REAL( ZARRAY( I))* SI( I) >*/
d__3 = cmag * .5;
d__2 = d__3 * cmag;
i__1 = i - 1;
d__1 = d__2 * zload_1.zarray[i__1].r;
fpat_1.ploss += d__1 * data_1.si[i - 1];
/*< 64 IF( JUMP) 68,69,65 >*/
L64:
if (jump < 0) {
goto L68;
} else if (jump == 0) {
goto L69;
} else {
goto L65;
}
/*< 65 IF( IPTAG.EQ.0) GOTO 66 >*/
L65:
if (iptag == 0) {
goto L66;
}
/*< IF( ITAG( I).NE. IPTAG) GOTO 69 >*/
if (data_1.itag[i - 1] != iptag) {
goto L69;
}
/*< 66 ITMP1= ITMP1+1 >*/
L66:
++itmp1;
/*< IF( ITMP1.LT. IPTAGF.OR. ITMP1.GT. IPTAGT) GOTO 69 >*/
if (itmp1 < iptagf || itmp1 > iptagt) {
goto L69;
}
/*< IF( IPTFLG.EQ.0) GOTO 68 >*/
if (iptflg == 0) {
goto L68;
}
/*< IF( IPTFLG.LT.2.OR. INC.GT. NORMF) GOTO 67 >*/
if (iptflg < 2 || inc > normf) {
goto L67;
}
/*< FNORM( INC)= CMAG >*/
fnorm[inc - 1] = cmag;
/*< ISAVE= I >*/
isave = i;
/*< 67 IF( IPTFLG.NE.3) WRITE( 6,164) XPR1, XPR2, CMAG, PH, I >*/
L67:
if (iptflg != 3) {
s_wsfe(&io___156);
do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
}
/*< GOTO 69 >*/
goto L69;
/* *** */
/*< >*/
L68:
s_wsfe(&io___157);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&curi, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IPLP1.NE.1) GOTO 69 >*/
if (plot_1.iplp1 != 1) {
goto L69;
}
/*< IF( IPLP2.EQ.1) WRITE( 8,*) CURI >*/
if (plot_1.iplp2 == 1) {
s_wsle(&io___158);
do_lio(&c__7, &c__1, (char *)&curi, (ftnlen)sizeof(doublecomplex))
;
e_wsle();
}
/* *** */
/*< IF( IPLP2.EQ.2) WRITE( 8,*) CMAG, PH >*/
if (plot_1.iplp2 == 2) {
s_wsle(&io___159);
do_lio(&c__5, &c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
e_wsle();
}
/*< 69 CONTINUE >*/
L69:
;
}
/*< IF( IPTFLQ.EQ.(-1)) GOTO 308 >*/
if (iptflq == -1) {
goto L308;
}
/*< WRITE( 6,315) >*/
s_wsfe(&io___160);
e_wsfe();
/*< ITMP1=0 >*/
itmp1 = 0;
/*< FR=1.D-6/ FMHZ >*/
fr = 1e-6 / save_1.fmhz;
/*< DO 316 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< IF( IPTFLQ.EQ.(-2)) GOTO 318 >*/
if (iptflq == -2) {
goto L318;
}
/*< IF( IPTAQ.EQ.0) GOTO 317 >*/
if (iptaq == 0) {
goto L317;
}
/*< IF( ITAG( I).NE. IPTAQ) GOTO 316 >*/
if (data_1.itag[i - 1] != iptaq) {
goto L316;
}
/*< 317 ITMP1= ITMP1+1 >*/
L317:
++itmp1;
/*< IF( ITMP1.LT. IPTAQF.OR. ITMP1.GT. IPTAQT) GOTO 316 >*/
if (itmp1 < iptaqf || itmp1 > iptaqt) {
goto L316;
}
/*< 318 CURI= FR* CMPLX(- BII( I), BIR( I)) >*/
L318:
d__1 = -crnt_1.bii[i - 1];
i__1 = i - 1;
z__2.r = d__1, z__2.i = crnt_1.bir[i__1];
z__1.r = fr * z__2.r, z__1.i = fr * z__2.i;
curi.r = z__1.r, curi.i = z__1.i;
/*< CMAG= ABS( CURI) >*/
cmag = z_abs(&curi);
/*< PH= CANG( CURI) >*/
ph = cang_(&curi);
/*< >*/
s_wsfe(&io___161);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&curi, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&cmag, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ph, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 316 CONTINUE >*/
L316:
;
}
/*< 308 IF( M.EQ.0) GOTO 310 >*/
L308:
if (data_1.m == 0) {
goto L310;
}
/*< WRITE( 6,197) >*/
s_wsfe(&io___162);
e_wsfe();
/*< J= N-2 >*/
j = data_1.n - 2;
/*< ITMP1= LD+1 >*/
itmp1 = data_1.ld + 1;
/*< DO 309 I=1, M >*/
i__2 = data_1.m;
for (i = 1; i <= i__2; ++i) {
/*< J= J+3 >*/
j += 3;
/*< ITMP1= ITMP1-1 >*/
--itmp1;
/*< EX= CUR( J) >*/
i__1 = j - 1;
ex.r = crnt_1.cur[i__1].r, ex.i = crnt_1.cur[i__1].i;
/*< EY= CUR( J+1) >*/
i__1 = j;
ey.r = crnt_1.cur[i__1].r, ey.i = crnt_1.cur[i__1].i;
/*< EZ= CUR( J+2) >*/
i__1 = j + 1;
ez.r = crnt_1.cur[i__1].r, ez.i = crnt_1.cur[i__1].i;
/*< ETH= EX* T1X( ITMP1)+ EY* T1Y( ITMP1)+ EZ* T1Z( ITMP1) >*/
i__1 = itmp1 - 1;
z__3.r = t1x[i__1] * ex.r, z__3.i = t1x[i__1] * ex.i;
i__3 = itmp1 - 1;
z__4.r = t1y[i__3] * ey.r, z__4.i = t1y[i__3] * ey.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = itmp1 - 1;
z__5.r = t1z[i__4] * ez.r, z__5.i = t1z[i__4] * ez.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
eth.r = z__1.r, eth.i = z__1.i;
/*< EPH= EX* T2X( ITMP1)+ EY* T2Y( ITMP1)+ EZ* T2Z( ITMP1) >*/
i__1 = itmp1 - 1;
z__3.r = t2x[i__1] * ex.r, z__3.i = t2x[i__1] * ex.i;
i__3 = itmp1 - 1;
z__4.r = t2y[i__3] * ey.r, z__4.i = t2y[i__3] * ey.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = itmp1 - 1;
z__5.r = t2z[i__4] * ez.r, z__5.i = t2z[i__4] * ez.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
eph.r = z__1.r, eph.i = z__1.i;
/*< ETHM= ABS( ETH) >*/
ethm = z_abs(ð);
/*< ETHA= CANG( ETH) >*/
etha = cang_(ð);
/*< EPHM= ABS( EPH) >*/
ephm = z_abs(&eph);
/* 309 WRITE(6,198) I,X(ITMP1),Y(ITMP1),Z(ITMP1),ETHM,ETHA,EPHM,EPHA
,E */
/* 1X,EY, EZ */
/* *** */
/*< EPHA= CANG( EPH) >*/
epha = cang_(&eph);
/*< >*/
s_wsfe(&io___172);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[itmp1 - 1], (ftnlen)sizeof(doublereal)
);
do_fio(&c__1, (char *)&data_1.y[itmp1 - 1], (ftnlen)sizeof(doublereal)
);
do_fio(&c__1, (char *)&data_1.z[itmp1 - 1], (ftnlen)sizeof(doublereal)
);
do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ex, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ey, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ez, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IPLP1.NE.1) GOTO 309 >*/
if (plot_1.iplp1 != 1) {
goto L309;
}
/*< IF( IPLP3.EQ.1) WRITE( 8,*) EX >*/
if (plot_1.iplp3 == 1) {
s_wsle(&io___173);
do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(doublecomplex));
e_wsle();
}
/*< IF( IPLP3.EQ.2) WRITE( 8,*) EY >*/
if (plot_1.iplp3 == 2) {
s_wsle(&io___174);
do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(doublecomplex));
e_wsle();
}
/*< IF( IPLP3.EQ.3) WRITE( 8,*) EZ >*/
if (plot_1.iplp3 == 3) {
s_wsle(&io___175);
do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(doublecomplex));
e_wsle();
}
/*< IF( IPLP3.EQ.4) WRITE( 8,*) EX, EY, EZ >*/
if (plot_1.iplp3 == 4) {
s_wsle(&io___176);
do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(doublecomplex));
do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(doublecomplex));
do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(doublecomplex));
e_wsle();
}
/* *** */
/*< 309 CONTINUE >*/
L309:
;
}
/*< 310 IF( IXTYP.NE.0.AND. IXTYP.NE.5) GOTO 70 >*/
L310:
if (fpat_1.ixtyp != 0 && fpat_1.ixtyp != 5) {
goto L70;
}
/*< TMP1= PIN- PNLS- PLOSS >*/
tmp1 = netcx_1.pin - netcx_1.pnls - fpat_1.ploss;
/*< TMP2=100.* TMP1/ PIN >*/
tmp2 = tmp1 * 100. / netcx_1.pin;
/*< WRITE( 6,166) PIN, TMP1, PLOSS, PNLS, TMP2 >*/
s_wsfe(&io___177);
do_fio(&c__1, (char *)&netcx_1.pin, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fpat_1.ploss, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&netcx_1.pnls, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 70 CONTINUE >*/
L70:
/*< IGO=4 >*/
igo = 4;
/*< IF( NCOUP.GT.0) CALL COUPLE( CUR, WLAM) >*/
if (yparm_1.ncoup > 0) {
couple_(crnt_1.cur, &data_1.wlam);
}
/*< IF( IFLOW.NE.7) GOTO 71 >*/
if (iflow != 7) {
goto L71;
}
/*< IF( IXTYP.GT.0.AND. IXTYP.LT.4) GOTO 113 >*/
if (fpat_1.ixtyp > 0 && fpat_1.ixtyp < 4) {
goto L113;
}
/*< IF( NFRQ.NE.1) GOTO 120 >*/
if (nfrq != 1) {
goto L120;
}
/*< WRITE( 6,135) >*/
s_wsfe(&io___178);
e_wsfe();
/*< GOTO 14 >*/
goto L14;
/* NEAR FIELD CALCULATION */
/*< 71 IGO=5 >*/
L71:
igo = 5;
/*< 72 IF( NEAR.EQ.(-1)) GOTO 78 >*/
L72:
if (fpat_1.near == -1) {
goto L78;
}
/*< CALL NFPAT >*/
nfpat_();
/*< IF( MHZ.EQ. NFRQ) NEAR=-1 >*/
if (mhz == nfrq) {
fpat_1.near = -1;
}
/*< IF( NFRQ.NE.1) GOTO 78 >*/
if (nfrq != 1) {
goto L78;
}
/*< WRITE( 6,135) >*/
s_wsfe(&io___179);
e_wsfe();
/* STANDARD FAR FIELD CALCULATION */
/*< GOTO 14 >*/
goto L14;
/*< 78 IF( IFAR.EQ.-1) GOTO 113 >*/
L78:
if (gnd_1.ifar == -1) {
goto L113;
}
/*< PINR= PIN >*/
fpat_1.pinr = netcx_1.pin;
/*< PNLR= PNLS >*/
fpat_1.pnlr = netcx_1.pnls;
/*< CALL RDPAT >*/
rdpat_();
/*< 113 IF( IXTYP.EQ.0.OR. IXTYP.GE.4) GOTO 119 >*/
L113:
if (fpat_1.ixtyp == 0 || fpat_1.ixtyp >= 4) {
goto L119;
}
/*< NTHIC= NTHIC+1 >*/
++nthic;
/*< INC= INC+1 >*/
++inc;
/*< XPR1= XPR1+ XPR4 >*/
xpr1 += xpr4;
/*< IF( NTHIC.LE. NTHI) GOTO 54 >*/
if (nthic <= nthi) {
goto L54;
}
/*< NTHIC=1 >*/
nthic = 1;
/*< XPR1= THETIS >*/
xpr1 = thetis;
/*< XPR2= XPR2+ XPR5 >*/
xpr2 += xpr5;
/*< NPHIC= NPHIC+1 >*/
++nphic;
/*< IF( NPHIC.LE. NPHI) GOTO 54 >*/
if (nphic <= nphi) {
goto L54;
}
/*< NPHIC=1 >*/
nphic = 1;
/*< XPR2= PHISS >*/
xpr2 = phiss;
/* NORMALIZED RECEIVING PATTERN PRINTED */
/*< IF( IPTFLG.LT.2) GOTO 119 >*/
if (iptflg < 2) {
goto L119;
}
/*< ITMP1= NTHI* NPHI >*/
itmp1 = nthi * nphi;
/*< IF( ITMP1.LE. NORMF) GOTO 114 >*/
if (itmp1 <= normf) {
goto L114;
}
/*< ITMP1= NORMF >*/
itmp1 = normf;
/*< WRITE( 6,181) >*/
s_wsfe(&io___180);
e_wsfe();
/*< 114 TMP1= FNORM(1) >*/
L114:
tmp1 = fnorm[0];
/*< DO 115 J=2, ITMP1 >*/
i__2 = itmp1;
for (j = 2; j <= i__2; ++j) {
/*< IF( FNORM( J).GT. TMP1) TMP1= FNORM( J) >*/
if (fnorm[j - 1] > tmp1) {
tmp1 = fnorm[j - 1];
}
/*< 115 CONTINUE >*/
/* L115: */
}
/*< WRITE( 6,182) TMP1, XPR3, HPOL( IXTYP), XPR6, ISAVE >*/
s_wsfe(&io___181);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, hpol + (fpat_1.ixtyp - 1) * 6, 6L);
do_fio(&c__1, (char *)&fpat_1.xpr6, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&isave, (ftnlen)sizeof(integer));
e_wsfe();
/*< DO 118 J=1, NPHI >*/
i__2 = nphi;
for (j = 1; j <= i__2; ++j) {
/*< ITMP2= NTHI*( J-1) >*/
itmp2 = nthi * (j - 1);
/*< DO 116 I=1, NTHI >*/
i__1 = nthi;
for (i = 1; i <= i__1; ++i) {
/*< ITMP3= I+ ITMP2 >*/
itmp3 = i + itmp2;
/*< IF( ITMP3.GT. ITMP1) GOTO 117 >*/
if (itmp3 > itmp1) {
goto L117;
}
/*< TMP2= FNORM( ITMP3)/ TMP1 >*/
tmp2 = fnorm[itmp3 - 1] / tmp1;
/*< TMP3= DB20( TMP2) >*/
tmp3 = db20_(&tmp2);
/*< WRITE( 6,183) XPR1, XPR2, TMP3, TMP2 >*/
s_wsfe(&io___182);
do_fio(&c__1, (char *)&xpr1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xpr2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< XPR1= XPR1+ XPR4 >*/
xpr1 += xpr4;
/*< 116 CONTINUE >*/
/* L116: */
}
/*< 117 XPR1= THETIS >*/
L117:
xpr1 = thetis;
/*< XPR2= XPR2+ XPR5 >*/
xpr2 += xpr5;
/*< 118 CONTINUE >*/
/* L118: */
}
/*< XPR2= PHISS >*/
xpr2 = phiss;
/*< 119 IF( MHZ.EQ. NFRQ) IFAR=-1 >*/
L119:
if (mhz == nfrq) {
gnd_1.ifar = -1;
}
/*< IF( NFRQ.NE.1) GOTO 120 >*/
if (nfrq != 1) {
goto L120;
}
/*< WRITE( 6,135) >*/
s_wsfe(&io___183);
e_wsfe();
/*< GOTO 14 >*/
goto L14;
/*< 120 MHZ= MHZ+1 >*/
L120:
++mhz;
/*< IF( MHZ.LE. NFRQ) GOTO 42 >*/
if (mhz <= nfrq) {
goto L42;
}
/*< IF( IPED.EQ.0) GOTO 123 >*/
if (iped == 0) {
goto L123;
}
/*< IF( NVQD.LT.1) GOTO 199 >*/
if (vsorc_1.nvqd < 1) {
goto L199;
}
/*< WRITE( 6,184) IVQD( NVQD), ZPNORM >*/
s_wsfe(&io___184);
do_fio(&c__1, (char *)&vsorc_1.ivqd[vsorc_1.nvqd - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&zpnorm, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 204 >*/
goto L204;
/*< 199 WRITE( 6,184) ISANT( NSANT), ZPNORM >*/
L199:
s_wsfe(&io___185);
do_fio(&c__1, (char *)&vsorc_1.isant[vsorc_1.nsant - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&zpnorm, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 204 ITMP1= NFRQ >*/
L204:
itmp1 = nfrq;
/*< IF( ITMP1.LE.( NORMF/4)) GOTO 121 >*/
if (itmp1 <= normf / 4) {
goto L121;
}
/*< ITMP1= NORMF/4 >*/
itmp1 = normf / 4;
/*< WRITE( 6,185) >*/
s_wsfe(&io___186);
e_wsfe();
/*< 121 IF( IFRQ.EQ.0) TMP1= FMHZ-( NFRQ-1)* DELFRQ >*/
L121:
if (ifrq == 0) {
tmp1 = save_1.fmhz - (nfrq - 1) * delfrq;
}
/*< IF( IFRQ.EQ.1) TMP1= FMHZ/( DELFRQ**( NFRQ-1)) >*/
if (ifrq == 1) {
i__2 = nfrq - 1;
tmp1 = save_1.fmhz / pow_di(&delfrq, &i__2);
}
/*< DO 122 I=1, ITMP1 >*/
i__2 = itmp1;
for (i = 1; i <= i__2; ++i) {
/*< ITMP2= I+4*( I-1) >*/
itmp2 = i + (i - 1 << 2);
/*< TMP2= FNORM( ITMP2)/ ZPNORM >*/
tmp2 = fnorm[itmp2 - 1] / zpnorm;
/*< TMP3= FNORM( ITMP2+1)/ ZPNORM >*/
tmp3 = fnorm[itmp2] / zpnorm;
/*< TMP4= FNORM( ITMP2+2)/ ZPNORM >*/
tmp4 = fnorm[itmp2 + 1] / zpnorm;
/*< TMP5= FNORM( ITMP2+3) >*/
tmp5 = fnorm[itmp2 + 2];
/*< >*/
s_wsfe(&io___187);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fnorm[itmp2 - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fnorm[itmp2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fnorm[itmp2 + 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fnorm[itmp2 + 2], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IFRQ.EQ.0) TMP1= TMP1+ DELFRQ >*/
if (ifrq == 0) {
tmp1 += delfrq;
}
/*< IF( IFRQ.EQ.1) TMP1= TMP1* DELFRQ >*/
if (ifrq == 1) {
tmp1 *= delfrq;
}
/*< 122 CONTINUE >*/
/* L122: */
}
/*< WRITE( 6,135) >*/
s_wsfe(&io___188);
e_wsfe();
/*< 123 CONTINUE >*/
L123:
/*< NFRQ=1 >*/
nfrq = 1;
/*< MHZ=1 >*/
mhz = 1;
/*< GOTO 14 >*/
goto L14;
/*< 125 FORMAT(A2,19A4) >*/
/*< 126 FORMAT('1') >*/
/*< >*/
/*< 128 FORMAT(////,37X,'- - - - COMMENTS - - - -',//) >*/
/*< 129 FORMAT(25X,20A4) >*/
/*< 130 FORMAT(///,10X,'INCORRECT LABEL FOR A COMMENT CARD') >*/
/*< 135 FORMAT(/////) >*/
/*< 136 FORMAT(A2,I3,3I5,6E10.3) >*/
/* L136: */
/*< >*/
/*< 138 FORMAT(///,10X,'FAULTY DATA CARD LABEL AFTER GEOMETRY SECTION') >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 146 FORMAT(///,30X,' - - - STRUCTURE IMPEDANCE LOADING - - -') >*/
/*< 147 FORMAT(/,35X,'THIS STRUCTURE IS NOT LOADED') >*/
/*< 148 FORMAT(///,34X,'- - - ANTENNA ENVIRONMENT - - -',/) >*/
/*< 149 FORMAT(40X,'MEDIUM UNDER SCREEN -') >*/
/*< >*/
/*< 151 FORMAT(42X,'PERFECT GROUND') >*/
/*< 152 FORMAT(44X,'FREE SPACE') >*/
/*< >*/
/*< 154 FORMAT(///,40X,'- - - EXCITATION - - -') >*/
/*< >*/
/*< >*/
/*< 157 FORMAT(4X,4(I5,1X),1P,6(3X,E11.4),3X,A6,A2) >*/
/*< 158 FORMAT(///,44X,'- - - NETWORK DATA - - -') >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 164 FORMAT(10X,2(F7.2,3X),1X,1P,E11.4,3X,0P,F7.2,4X,I5) >*/
/*< 165 FORMAT(1X,2I5,3F9.4,F9.5,1X,1P,3E12.4,0P,F9.3) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 183 FORMAT(20X,2(F7.2,3X),1X,F7.2,4X,1P,E11.4) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 198 FORMAT(1X,I4,/,1X,3F7.3,2(1P,E11.4,0P,F8.2),1P,6E10.2) >*/
/*< 201 FORMAT(/,' RUN TIME =',F10.3) >*/
/*< >*/
/*< 321 FORMAT(/,20X,'THE EXTENDED THIN WIRE KERNEL WILL BE USED') >*/
/*< 303 FORMAT(/,' ERROR - ',A2,' CARD IS NOT ALLOWED WITH N.G.F.') >*/
/*< 327 FORMAT(/,35X,' LOADING ONLY IN N.G.F. SECTION') >*/
/*< 302 FORMAT(' ERROR - N.G.F. IN USE. CANNOT WRITE NEW N.G.F.') >*/
/*< >*/
/*< >*/
/*< >*/
/*< 392 FORMAT(40X,'FINITE GROUND. SOMMERFELD SOLUTION') >*/
/*< >*/
/*< END >*/
} /* MAIN__ */
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE ARC( ITG, NS, RADA, ANG1, ANG2, RAD) >*/
/* Subroutine */ int arc_(itg, ns, rada, ang1, ang2, rad)
integer *itg, *ns;
doublereal *rada, *ang1, *ang2, *rad;
{
/* Initialized data */
static doublereal ta = .01745329252;
/* Format strings */
static char fmt_3[] = "(\002 ERROR -- ARC ANGLE EXCEEDS 360. DEGREES\002)"
;
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
double cos(), sin();
/* Local variables */
static doublereal dang;
static integer i;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal xs1, xs2, zs1, zs2, ang;
static integer ist;
/* Fortran I/O blocks */
static cilist io___194 = { 0, 6, 0, fmt_3, 0 };
/* *** */
/* ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< DIMENSION X2(1), Y2(1), Z2(1) >*/
/*< >*/
/*< EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET) >*/
/*< DATA TA/.01745329252D+0/ >*/
/*< IST= N+1 >*/
ist = data_1.n + 1;
/*< N= N+ NS >*/
data_1.n += *ns;
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< IF( NS.LT.1) RETURN >*/
if (*ns < 1) {
return 0;
}
/*< IF( ABS( ANG2- ANG1).LT.360.00001D+0) GOTO 1 >*/
if ((d__1 = *ang2 - *ang1, abs(d__1)) < 360.00001) {
goto L1;
}
/*< WRITE( 6,3) >*/
s_wsfe(&io___194);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 1 ANG= ANG1* TA >*/
L1:
ang = *ang1 * ta;
/*< DANG=( ANG2- ANG1)* TA/ NS >*/
dang = (*ang2 - *ang1) * ta / *ns;
/*< XS1= RADA* COS( ANG) >*/
xs1 = *rada * cos(ang);
/*< ZS1= RADA* SIN( ANG) >*/
zs1 = *rada * sin(ang);
/*< DO 2 I= IST, N >*/
i__1 = data_1.n;
for (i = ist; i <= i__1; ++i) {
/*< ANG= ANG+ DANG >*/
ang += dang;
/*< XS2= RADA* COS( ANG) >*/
xs2 = *rada * cos(ang);
/*< ZS2= RADA* SIN( ANG) >*/
zs2 = *rada * sin(ang);
/*< X( I)= XS1 >*/
data_1.x[i - 1] = xs1;
/*< Y( I)=0. >*/
data_1.y[i - 1] = 0.;
/*< Z( I)= ZS1 >*/
data_1.z[i - 1] = zs1;
/*< X2( I)= XS2 >*/
x2[i - 1] = xs2;
/*< Y2( I)=0. >*/
y2[i - 1] = 0.;
/*< Z2( I)= ZS2 >*/
z2[i - 1] = zs2;
/*< XS1= XS2 >*/
xs1 = xs2;
/*< ZS1= ZS2 >*/
zs1 = zs2;
/*< BI( I)= RAD >*/
data_1.bi[i - 1] = *rad;
/*< 2 ITAG( I)= ITG >*/
/* L2: */
data_1.itag[i - 1] = *itg;
}
/*< RETURN >*/
return 0;
/*< 3 FORMAT(' ERROR -- ARC ANGLE EXCEEDS 360. DEGREES') >*/
/*< END >*/
} /* arc_ */
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< FUNCTION ATGN2( X, Y) >*/
doublereal atgn2_(x, y)
doublereal *x, *y;
{
/* System generated locals */
doublereal ret_val;
/* Builtin functions */
double atan2();
/* *** */
/* ATGN2 IS ARCTANGENT FUNCTION MODIFIED TO RETURN 0. WHEN X=Y=0. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< IF( X) 3,1,3 >*/
if (*x != 0.) {
goto L3;
} else {
goto L1;
}
/*< 1 IF( Y) 3,2,3 >*/
L1:
if (*y != 0.) {
goto L3;
} else {
goto L2;
}
/*< 2 ATGN2=0. >*/
L2:
ret_val = 0.;
/*< RETURN >*/
return ret_val;
/*< 3 ATGN2= ATAN2( X, Y) >*/
L3:
ret_val = atan2(*x, *y);
/*< RETURN >*/
return ret_val;
/*< END >*/
} /* atgn2_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE BLCKOT( AR, NUNIT, IX1, IX2, NBLKS, NEOF) >*/
/* Subroutine */ int blckot_0_(n__, ar, nunit, ix1, ix2, nblks, neof)
int n__;
doublecomplex *ar;
integer *nunit, *ix1, *ix2, *nblks, *neof;
{
/* Format strings */
static char fmt_4[] = "(\002 EOF ON UNIT\002,i3,\002 NBLKS= \002,i3\
,\002 NEOF= \002,i5)";
/* System generated locals */
integer i__1, i__2, i__3;
/* Builtin functions */
integer s_wsue(), do_uio(), e_wsue(), s_rsue(), e_rsue(), s_wsfe(),
do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer i, j, i1, i2;
/* Fortran I/O blocks */
static cilist io___204 = { 0, 0, 0, 0, 0 };
static cilist io___207 = { 0, 0, 1, 0, 0 };
static cilist io___208 = { 0, 6, 0, fmt_4, 0 };
/* *** */
/* BLCKOT CONTROLS THE READING AND WRITING OF MATRIX BLOCKS ON FILES
*/
/* FOR THE OUT-OF-CORE MATRIX SOLUTION. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< LOGICAL ENF >*/
/*< COMPLEX AR >*/
/*< DIMENSION AR(1000) >*/
/*< I1=( IX1+1)/2 >*/
/* Parameter adjustments */
--ar;
/* Function Body */
switch(n__) {
case 1: goto L_blckin;
}
i1 = (*ix1 + 1) / 2;
/*< I2=( IX2+1)/2 >*/
i2 = (*ix2 + 1) / 2;
/*< 1 WRITE( NUNIT) ( AR( J), J= I1, I2) >*/
/* L1: */
io___204.ciunit = *nunit;
s_wsue(&io___204);
i__1 = i2;
for (j = i1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&ar[j], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< RETURN >*/
return 0;
/*< ENTRY BLCKIN( AR, NUNIT, IX1, IX2, NBLKS, NEOF) >*/
L_blckin:
/*< I1=( IX1+1)/2 >*/
i1 = (*ix1 + 1) / 2;
/*< I2=( IX2+1)/2 >*/
i2 = (*ix2 + 1) / 2;
/*< DO 2 I=1, NBLKS >*/
i__1 = *nblks;
for (i = 1; i <= i__1; ++i) {
/* IF (ENF(NUNIT)) GO TO 3 */
/*< READ( NUNIT,END=3) ( AR( J), J= I1, I2) >*/
io___207.ciunit = *nunit;
i__2 = s_rsue(&io___207);
if (i__2 != 0) {
goto L3;
}
i__3 = i2;
for (j = i1; j <= i__3; ++j) {
i__2 = do_uio(&c__2, (char *)&ar[j], (ftnlen)sizeof(doublereal));
if (i__2 != 0) {
goto L3;
}
}
i__2 = e_rsue();
if (i__2 != 0) {
goto L3;
}
/*< 2 CONTINUE >*/
/* L2: */
}
/*< RETURN >*/
return 0;
/*< 3 WRITE( 6,4) NUNIT, NBLKS, NEOF >*/
L3:
s_wsfe(&io___208);
do_fio(&c__1, (char *)&(*nunit), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*nblks), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*neof), (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( NEOF.NE.777) STOP >*/
if (*neof != 777) {
s_stop("", 0L);
}
/*< NEOF=0 >*/
*neof = 0;
/*< RETURN >*/
return 0;
/*< 4 FORMAT(' EOF ON UNIT',I3,' NBLKS= ',I3,' NEOF= ',I5) >*/
/*< END >*/
} /* blckot_ */
/* Subroutine */ int blckot_(ar, nunit, ix1, ix2, nblks, neof)
doublecomplex *ar;
integer *nunit, *ix1, *ix2, *nblks, *neof;
{
return blckot_0_(0, ar, nunit, ix1, ix2, nblks, neof);
}
/* Subroutine */ int blckin_(ar, nunit, ix1, ix2, nblks, neof)
doublecomplex *ar;
integer *nunit, *ix1, *ix2, *nblks, *neof;
{
return blckot_0_(1, ar, nunit, ix1, ix2, nblks, neof);
}
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CABC( CURX) >*/
/* Subroutine */ int cabc_(curx)
doublecomplex *curx;
{
/* Initialized data */
static doublereal tp = 6.283185308;
static struct {
doublereal e_1[3];
} equiv_6 = { 0., -.01666666667, 0. };
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
double d_imag(), log(), cos(), sin();
/* Local variables */
#define ccjx ((doublereal *)&equiv_6)
static doublecomplex curd;
static integer i, j, k;
static doublereal ai, ar;
static integer is;
static doublereal sh;
static integer jx;
static doublecomplex cs1, cs2;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define ccj ((doublecomplex *)&equiv_6)
extern /* Subroutine */ int tbf_();
static integer jco1, jco2;
/* *** */
/* CABC COMPUTES COEFFICIENTS OF THE CONSTANT (A), SINE (B), AND */
/* COSINE (C) TERMS IN THE CURRENT INTERPOLATION FUNCTIONS FOR THE */
/* CURRENT VECTOR CUR. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX CUR, CURX, VQDS, CURD, CCJ, VSANT, VQD, CS1, CS2 >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< DIMENSION CURX(1), CCJX(2) >*/
/*< >*/
/*< EQUIVALENCE(CCJ,CCJX) >*/
/*< DATA TP/6.283185308D+0/, CCJX/0.,-0.01666666667D+0/ >*/
/* Parameter adjustments */
--curx;
/* Function Body */
/*< IF( N.EQ.0) GOTO 6 >*/
if (data_1.n == 0) {
goto L6;
}
/*< DO 1 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< AIR( I)=0. >*/
crnt_1.air[i - 1] = 0.;
/*< AII( I)=0. >*/
crnt_1.aii[i - 1] = 0.;
/*< BIR( I)=0. >*/
crnt_1.bir[i - 1] = 0.;
/*< BII( I)=0. >*/
crnt_1.bii[i - 1] = 0.;
/*< CIR( I)=0. >*/
crnt_1.cir[i - 1] = 0.;
/*< 1 CII( I)=0. >*/
/* L1: */
crnt_1.cii[i - 1] = 0.;
}
/*< DO 2 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< AR= REAL( CURX( I)) >*/
i__2 = i;
ar = curx[i__2].r;
/*< AI= AIMAG( CURX( I)) >*/
ai = d_imag(&curx[i]);
/*< CALL TBF( I,1) >*/
tbf_(&i, &c__1);
/*< DO 2 JX=1, JSNO >*/
i__2 = segj_1.jsno;
for (jx = 1; jx <= i__2; ++jx) {
/*< J= JCO( JX) >*/
j = segj_1.jco[jx - 1];
/*< AIR( J)= AIR( J)+ AX( JX)* AR >*/
crnt_1.air[j - 1] += segj_1.ax[jx - 1] * ar;
/*< AII( J)= AII( J)+ AX( JX)* AI >*/
crnt_1.aii[j - 1] += segj_1.ax[jx - 1] * ai;
/*< BIR( J)= BIR( J)+ BX( JX)* AR >*/
crnt_1.bir[j - 1] += segj_1.bx[jx - 1] * ar;
/*< BII( J)= BII( J)+ BX( JX)* AI >*/
crnt_1.bii[j - 1] += segj_1.bx[jx - 1] * ai;
/*< CIR( J)= CIR( J)+ CX( JX)* AR >*/
crnt_1.cir[j - 1] += segj_1.cx[jx - 1] * ar;
/*< 2 CII( J)= CII( J)+ CX( JX)* AI >*/
/* L2: */
crnt_1.cii[j - 1] += segj_1.cx[jx - 1] * ai;
}
}
/*< IF( NQDS.EQ.0) GOTO 4 >*/
if (vsorc_1.nqds == 0) {
goto L4;
}
/*< DO 3 IS=1, NQDS >*/
i__2 = vsorc_1.nqds;
for (is = 1; is <= i__2; ++is) {
/*< I= IQDS( IS) >*/
i = vsorc_1.iqds[is - 1];
/*< JX= ICON1( I) >*/
jx = data_1.icon1[i - 1];
/*< ICON1( I)=0 >*/
data_1.icon1[i - 1] = 0;
/*< CALL TBF( I,0) >*/
tbf_(&i, &c__0);
/*< ICON1( I)= JX >*/
data_1.icon1[i - 1] = jx;
/*< SH= SI( I)*.5 >*/
sh = data_1.si[i - 1] * .5;
/*< >*/
i__1 = is - 1;
z__2.r = ccj->r * vsorc_1.vqds[i__1].r - ccj->i * vsorc_1.vqds[i__1]
.i, z__2.i = ccj->r * vsorc_1.vqds[i__1].i + ccj->i *
vsorc_1.vqds[i__1].r;
d__2 = (log(sh * 2. / data_1.bi[i - 1]) - 1.) * (segj_1.bx[
segj_1.jsno - 1] * cos(tp * sh) + segj_1.cx[segj_1.jsno - 1] *
sin(tp * sh));
d__1 = d__2 * data_1.wlam;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
curd.r = z__1.r, curd.i = z__1.i;
/*< AR= REAL( CURD) >*/
ar = curd.r;
/*< AI= AIMAG( CURD) >*/
ai = d_imag(&curd);
/*< DO 3 JX=1, JSNO >*/
i__1 = segj_1.jsno;
for (jx = 1; jx <= i__1; ++jx) {
/*< J= JCO( JX) >*/
j = segj_1.jco[jx - 1];
/*< AIR( J)= AIR( J)+ AX( JX)* AR >*/
crnt_1.air[j - 1] += segj_1.ax[jx - 1] * ar;
/*< AII( J)= AII( J)+ AX( JX)* AI >*/
crnt_1.aii[j - 1] += segj_1.ax[jx - 1] * ai;
/*< BIR( J)= BIR( J)+ BX( JX)* AR >*/
crnt_1.bir[j - 1] += segj_1.bx[jx - 1] * ar;
/*< BII( J)= BII( J)+ BX( JX)* AI >*/
crnt_1.bii[j - 1] += segj_1.bx[jx - 1] * ai;
/*< CIR( J)= CIR( J)+ CX( JX)* AR >*/
crnt_1.cir[j - 1] += segj_1.cx[jx - 1] * ar;
/*< 3 CII( J)= CII( J)+ CX( JX)* AI >*/
/* L3: */
crnt_1.cii[j - 1] += segj_1.cx[jx - 1] * ai;
}
}
/*< 4 DO 5 I=1, N >*/
L4:
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< 5 CURX( I)= CMPLX( AIR( I)+ CIR( I), AII( I)+ CII( I)) >*/
/* L5: */
i__2 = i;
d__1 = crnt_1.air[i - 1] + crnt_1.cir[i - 1];
d__2 = crnt_1.aii[i - 1] + crnt_1.cii[i - 1];
z__1.r = d__1, z__1.i = d__2;
curx[i__2].r = z__1.r, curx[i__2].i = z__1.i;
}
/* CONVERT SURFACE CURRENTS FROM T1,T2 COMPONENTS TO X,Y,Z COMPONENTS
*/
/*< 6 IF( M.EQ.0) RETURN >*/
L6:
if (data_1.m == 0) {
return 0;
}
/*< K= LD- M >*/
k = data_1.ld - data_1.m;
/*< JCO1= N+2* M+1 >*/
jco1 = data_1.n + (data_1.m << 1) + 1;
/*< JCO2= JCO1+ M >*/
jco2 = jco1 + data_1.m;
/*< DO 7 I=1, M >*/
i__2 = data_1.m;
for (i = 1; i <= i__2; ++i) {
/*< K= K+1 >*/
++k;
/*< JCO1= JCO1-2 >*/
jco1 += -2;
/*< JCO2= JCO2-3 >*/
jco2 += -3;
/*< CS1= CURX( JCO1) >*/
i__1 = jco1;
cs1.r = curx[i__1].r, cs1.i = curx[i__1].i;
/*< CS2= CURX( JCO1+1) >*/
i__1 = jco1 + 1;
cs2.r = curx[i__1].r, cs2.i = curx[i__1].i;
/*< CURX( JCO2)= CS1* T1X( K)+ CS2* T2X( K) >*/
i__1 = jco2;
i__3 = k - 1;
z__2.r = t1x[i__3] * cs1.r, z__2.i = t1x[i__3] * cs1.i;
i__4 = k - 1;
z__3.r = t2x[i__4] * cs2.r, z__3.i = t2x[i__4] * cs2.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
/*< CURX( JCO2+1)= CS1* T1Y( K)+ CS2* T2Y( K) >*/
i__1 = jco2 + 1;
i__3 = k - 1;
z__2.r = t1y[i__3] * cs1.r, z__2.i = t1y[i__3] * cs1.i;
i__4 = k - 1;
z__3.r = t2y[i__4] * cs2.r, z__3.i = t2y[i__4] * cs2.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
/*< 7 CURX( JCO2+2)= CS1* T1Z( K)+ CS2* T2Z( K) >*/
/* L7: */
i__1 = jco2 + 2;
i__3 = k - 1;
z__2.r = t1z[i__3] * cs1.r, z__2.i = t1z[i__3] * cs1.i;
i__4 = k - 1;
z__3.r = t2z[i__4] * cs2.r, z__3.i = t2z[i__4] * cs2.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
curx[i__1].r = z__1.r, curx[i__1].i = z__1.i;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* cabc_ */
#undef ccj
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef ccjx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< FUNCTION CANG( Z) >*/
doublereal cang_(z)
doublecomplex *z;
{
/* System generated locals */
doublereal ret_val, d__1, d__2;
/* Builtin functions */
double d_imag();
/* Local variables */
extern doublereal atgn2_();
/* *** */
/* CANG RETURNS THE PHASE ANGLE OF A COMPLEX NUMBER IN DEGREES. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMPLEX Z >*/
/*< CANG= ATGN2( AIMAG( Z), REAL( Z))*57.29577951D+0 >*/
d__1 = d_imag(z);
d__2 = z->r;
ret_val = atgn2_(&d__1, &d__2) * 57.29577951;
/*< RETURN >*/
return ret_val;
/*< END >*/
} /* cang_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMNGF( CB, CC, CD, NB, NC, ND, RKHX, IEXKX) >*/
/* Subroutine */ int cmngf_(cb, cc, cd, nb, nc, nd, rkhx, iexkx)
doublecomplex *cb, *cc, *cd;
integer *nb, *nc, *nd;
doublereal *rkhx;
integer *iexkx;
{
/* System generated locals */
integer cb_dim1, cb_offset, cc_dim1, cc_offset, cd_dim1, cd_offset, i__1,
i__2, i__3, i__4, i__5;
doublereal d__1;
doublecomplex z__1, z__2;
alist al__1;
/* Builtin functions */
integer f_rew(), s_wsue(), do_uio(), e_wsue();
/* Local variables */
static integer iblk, neqn, neqp;
extern /* Subroutine */ int cmss_();
static integer neqs;
extern /* Subroutine */ int cmws_(), cmsw_(), trio_(), cmww_();
static integer isvv, i, j, neqsp, i1, i2, it, ir, ix, jx, im1, in2, im2,
in1;
extern /* Subroutine */ int tbf_();
static integer meq, imx, ist, isv, itx, jss, jsx, m1eq, m2eq;
/* Fortran I/O blocks */
static cilist io___256 = { 0, 14, 0, 0, 0 };
static cilist io___259 = { 0, 12, 0, 0, 0 };
static cilist io___260 = { 0, 15, 0, 0, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* CMNGF FILLS INTERACTION MATRICIES B, C, AND D FOR N.G.F. SOLUTION
*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< DIMENSION CB( NB,1), CC( NC,1), CD( ND,1) >*/
/*< RKH= RKHX >*/
/* Parameter adjustments */
cd_dim1 = *nd;
cd_offset = cd_dim1 + 1;
cd -= cd_offset;
cc_dim1 = *nc;
cc_offset = cc_dim1 + 1;
cc -= cc_offset;
cb_dim1 = *nb;
cb_offset = cb_dim1 + 1;
cb -= cb_offset;
/* Function Body */
dataj_1.rkh = *rkhx;
/*< IEXK= IEXKX >*/
dataj_1.iexk = *iexkx;
/*< M1EQ=2* M1 >*/
m1eq = data_1.m1 << 1;
/*< M2EQ= M1EQ+1 >*/
m2eq = m1eq + 1;
/*< MEQ=2* M >*/
meq = data_1.m << 1;
/*< NEQP= ND- NPCON*2 >*/
neqp = *nd - (segj_1.npcon << 1);
/*< NEQS= NEQP- NSCON >*/
neqs = neqp - segj_1.nscon;
/*< NEQSP= NEQS+ NC >*/
neqsp = neqs + *nc;
/*< NEQN= NC+ N- N1 >*/
neqn = *nc + data_1.n - data_1.n1;
/*< ITX=1 >*/
itx = 1;
/*< IF( NSCON.GT.0) ITX=2 >*/
if (segj_1.nscon > 0) {
itx = 2;
}
/*< IF( ICASX.EQ.1) GOTO 1 >*/
if (matpar_1.icasx == 1) {
goto L1;
}
/*< REWIND 12 >*/
al__1.aerr = 0;
al__1.aunit = 12;
f_rew(&al__1);
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< REWIND 15 >*/
al__1.aerr = 0;
al__1.aunit = 15;
f_rew(&al__1);
/*< IF( ICASX.GT.2) GOTO 5 >*/
if (matpar_1.icasx > 2) {
goto L5;
}
/*< 1 DO 4 J=1, ND >*/
L1:
i__1 = *nd;
for (j = 1; j <= i__1; ++j) {
/*< DO 2 I=1, ND >*/
i__2 = *nd;
for (i = 1; i <= i__2; ++i) {
/*< 2 CD( I, J)=(0.,0.) >*/
/* L2: */
i__3 = i + j * cd_dim1;
cd[i__3].r = 0., cd[i__3].i = 0.;
}
/*< DO 3 I=1, NB >*/
i__3 = *nb;
for (i = 1; i <= i__3; ++i) {
/*< CB( I, J)=(0.,0.) >*/
i__2 = i + j * cb_dim1;
cb[i__2].r = 0., cb[i__2].i = 0.;
/*< 3 CC( I, J)=(0.,0.) >*/
/* L3: */
i__2 = i + j * cc_dim1;
cc[i__2].r = 0., cc[i__2].i = 0.;
}
/*< 4 CONTINUE >*/
/* L4: */
}
/*< 5 IST= N- N1+1 >*/
L5:
ist = data_1.n - data_1.n1 + 1;
/*< IT= NPBX >*/
it = matpar_1.npbx;
/* LOOP THRU 24 FILLS B. FOR ICASX=1 OR 2 ALSO FILLS D(WW), D(WS) */
/*< ISV=- NPBX >*/
isv = -matpar_1.npbx;
/*< DO 24 IBLK=1, NBBX >*/
i__1 = matpar_1.nbbx;
for (iblk = 1; iblk <= i__1; ++iblk) {
/*< ISV= ISV+ NPBX >*/
isv += matpar_1.npbx;
/*< IF( IBLK.EQ. NBBX) IT= NLBX >*/
if (iblk == matpar_1.nbbx) {
it = matpar_1.nlbx;
}
/*< IF( ICASX.LT.3) GOTO 7 >*/
if (matpar_1.icasx < 3) {
goto L7;
}
/*< DO 6 J=1, ND >*/
i__2 = *nd;
for (j = 1; j <= i__2; ++j) {
/*< DO 6 I=1, IT >*/
i__3 = it;
for (i = 1; i <= i__3; ++i) {
/*< 6 CB( I, J)=(0.,0.) >*/
/* L6: */
i__4 = i + j * cb_dim1;
cb[i__4].r = 0., cb[i__4].i = 0.;
}
}
/*< 7 I1= ISV+1 >*/
L7:
i1 = isv + 1;
/*< I2= ISV+ IT >*/
i2 = isv + it;
/*< IN2= I2 >*/
in2 = i2;
/*< IF( IN2.GT. N1) IN2= N1 >*/
if (in2 > data_1.n1) {
in2 = data_1.n1;
}
/*< IM1= I1- N1 >*/
im1 = i1 - data_1.n1;
/*< IM2= I2- N1 >*/
im2 = i2 - data_1.n1;
/*< IF( IM1.LT.1) IM1=1 >*/
if (im1 < 1) {
im1 = 1;
}
/*< IMX=1 >*/
imx = 1;
/*< IF( I1.LE. N1) IMX= N1- I1+2 >*/
if (i1 <= data_1.n1) {
imx = data_1.n1 - i1 + 2;
}
/* FILL B(WW),B(WS). FOR ICASX=1,2 FILL D(WW),D(WS) */
/*< IF( N2.GT. N) GOTO 12 >*/
if (data_1.n2 > data_1.n) {
goto L12;
}
/*< DO 11 J= N2, N >*/
i__4 = data_1.n;
for (j = data_1.n2; j <= i__4; ++j) {
/*< CALL TRIO( J) >*/
trio_(&j);
/*< DO 9 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< JSS= JCO( I) >*/
jss = segj_1.jco[i - 1];
/* SET JCO WHEN SOURCE IS NEW BASIS FUNCTION ON NEW SEGMEN
T */
/*< IF( JSS.LT. N2) GOTO 8 >*/
if (jss < data_1.n2) {
goto L8;
}
/*< JCO( I)= JSS- N1 >*/
segj_1.jco[i - 1] = jss - data_1.n1;
/* SOURCE IS PORTION OF MODIFIED BASIS FUNCTION ON NEW SEG
MENT */
/*< GOTO 9 >*/
goto L9;
/*< 8 JCO( I)= NEQS+ ICONX( JSS) >*/
L8:
segj_1.jco[i - 1] = neqs + data_1.iconx[jss - 1];
/*< 9 CONTINUE >*/
L9:
;
}
/*< IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0) >*/
if (i1 <= in2) {
cmww_(&j, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset], nb, &
c__0);
}
/*< >*/
if (im1 <= im2) {
cmws_(&j, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[cb_offset],
nb, &c__0);
}
/*< IF( ICASX.GT.2) GOTO 11 >*/
if (matpar_1.icasx > 2) {
goto L11;
}
/*< CALL CMWW( J, N2, N, CD, ND, CD, ND,1) >*/
cmww_(&j, &data_1.n2, &data_1.n, &cd[cd_offset], nd, &cd[
cd_offset], nd, &c__1);
/* LOADING IN D(WW) */
/*< IF( M2.LE. M) CALL CMWS( J, M2EQ, MEQ, CD(1, IST), ND, CD, ND,1) >*/
if (data_1.m2 <= data_1.m) {
cmws_(&j, &m2eq, &meq, &cd[ist * cd_dim1 + 1], nd, &cd[
cd_offset], nd, &c__1);
}
/*< IF( NLOAD.EQ.0) GOTO 11 >*/
if (zload_1.nload == 0) {
goto L11;
}
/*< IR= J- N1 >*/
ir = j - data_1.n1;
/*< EXK= ZARRAY( J) >*/
i__3 = j - 1;
dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i =
zload_1.zarray[i__3].i;
/*< DO 10 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< JSS= JCO( I) >*/
jss = segj_1.jco[i - 1];
/*< 10 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK >*/
/* L10: */
i__2 = jss + ir * cd_dim1;
i__5 = jss + ir * cd_dim1;
d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
z__1.r = cd[i__5].r - z__2.r, z__1.i = cd[i__5].i - z__2.i;
cd[i__2].r = z__1.r, cd[i__2].i = z__1.i;
}
/*< 11 CONTINUE >*/
L11:
;
}
/* FILL B(WW)PRIME */
/*< 12 IF( NSCON.EQ.0) GOTO 20 >*/
L12:
if (segj_1.nscon == 0) {
goto L20;
}
/*< DO 19 I=1, NSCON >*/
i__4 = segj_1.nscon;
for (i = 1; i <= i__4; ++i) {
/* SOURCES ARE NEW OR MODIFIED BASIS FUNCTIONS ON OLD SEGMENTS
WHICH */
/* CONNECT TO NEW SEGMENTS */
/*< J= ISCON( I) >*/
j = segj_1.iscon[i - 1];
/*< CALL TRIO( J) >*/
trio_(&j);
/*< JSS=0 >*/
jss = 0;
/*< DO 15 IX=1, JSNO >*/
i__2 = segj_1.jsno;
for (ix = 1; ix <= i__2; ++ix) {
/*< IR= JCO( IX) >*/
ir = segj_1.jco[ix - 1];
/*< IF( IR.LT. N2) GOTO 13 >*/
if (ir < data_1.n2) {
goto L13;
}
/*< IR= IR- N1 >*/
ir -= data_1.n1;
/*< GOTO 14 >*/
goto L14;
/*< 13 IR= ICONX( IR) >*/
L13:
ir = data_1.iconx[ir - 1];
/*< IF( IR.EQ.0) GOTO 15 >*/
if (ir == 0) {
goto L15;
}
/*< IR= NEQS+ IR >*/
ir = neqs + ir;
/*< 14 JSS= JSS+1 >*/
L14:
++jss;
/*< JCO( JSS)= IR >*/
segj_1.jco[jss - 1] = ir;
/*< AX( JSS)= AX( IX) >*/
segj_1.ax[jss - 1] = segj_1.ax[ix - 1];
/*< BX( JSS)= BX( IX) >*/
segj_1.bx[jss - 1] = segj_1.bx[ix - 1];
/*< CX( JSS)= CX( IX) >*/
segj_1.cx[jss - 1] = segj_1.cx[ix - 1];
/*< 15 CONTINUE >*/
L15:
;
}
/*< JSNO= JSS >*/
segj_1.jsno = jss;
/*< IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CB, NB, CB, NB,0) >*/
if (i1 <= in2) {
cmww_(&j, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset], nb, &
c__0);
}
/* SOURCE IS SINGULAR COMPONENT OF PATCH CURRENT THAT IS PART
OF */
/* MODIFIED BASIS FUNCTION FOR OLD SEGMENT THAT CONNECTS TO A
NEW */
/* SEGMENT ON END OPPOSITE PATCH. */
/*< >*/
if (im1 <= im2) {
cmws_(&j, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[cb_offset],
nb, &c__0);
}
/*< IF( I1.LE. IN2) CALL CMSW( J, I, I1, IN2, CB, CB,0, NB,-1) >*/
if (i1 <= in2) {
cmsw_(&j, &i, &i1, &in2, &cb[cb_offset], &cb[cb_offset], &
c__0, nb, &c_n1);
}
/*< IF( NLODF.EQ.0) GOTO 17 >*/
if (zload_1.nlodf == 0) {
goto L17;
}
/*< JX= J- ISV >*/
jx = j - isv;
/*< IF( JX.LT.1.OR. JX.GT. IT) GOTO 17 >*/
if (jx < 1 || jx > it) {
goto L17;
}
/*< EXK= ZARRAY( J) >*/
i__2 = j - 1;
dataj_1.exk.r = zload_1.zarray[i__2].r, dataj_1.exk.i =
zload_1.zarray[i__2].i;
/*< DO 16 IX=1, JSNO >*/
i__2 = segj_1.jsno;
for (ix = 1; ix <= i__2; ++ix) {
/*< JSS= JCO( IX) >*/
jss = segj_1.jco[ix - 1];
/* SOURCES ARE PORTIONS OF MODIFIED BASIS FUNCTION J ON OL
D SEGMENTS */
/* EXCLUDING OLD SEGMENTS THAT DIRECTLY CONNECT TO NEW SEG
MENTS. */
/*< 16 CB( JX, JSS)= CB( JX, JSS)-( AX( IX)+ CX( IX))* EXK >*/
/* L16: */
i__5 = jx + jss * cb_dim1;
i__3 = jx + jss * cb_dim1;
d__1 = segj_1.ax[ix - 1] + segj_1.cx[ix - 1];
z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
z__1.r = cb[i__3].r - z__2.r, z__1.i = cb[i__3].i - z__2.i;
cb[i__5].r = z__1.r, cb[i__5].i = z__1.i;
}
/*< 17 CALL TBF( J,1) >*/
L17:
tbf_(&j, &c__1);
/*< JSX= JSNO >*/
jsx = segj_1.jsno;
/*< JSNO=1 >*/
segj_1.jsno = 1;
/*< IR= JCO(1) >*/
ir = segj_1.jco[0];
/*< JCO(1)= NEQS+ I >*/
segj_1.jco[0] = neqs + i;
/*< DO 19 IX=1, JSX >*/
i__5 = jsx;
for (ix = 1; ix <= i__5; ++ix) {
/*< IF( IX.EQ.1) GOTO 18 >*/
if (ix == 1) {
goto L18;
}
/*< IR= JCO( IX) >*/
ir = segj_1.jco[ix - 1];
/*< AX(1)= AX( IX) >*/
segj_1.ax[0] = segj_1.ax[ix - 1];
/*< BX(1)= BX( IX) >*/
segj_1.bx[0] = segj_1.bx[ix - 1];
/*< CX(1)= CX( IX) >*/
segj_1.cx[0] = segj_1.cx[ix - 1];
/*< 18 IF( IR.GT. N1) GOTO 19 >*/
L18:
if (ir > data_1.n1) {
goto L19;
}
/*< IF( ICONX( IR).NE.0) GOTO 19 >*/
if (data_1.iconx[ir - 1] != 0) {
goto L19;
}
/*< IF( I1.LE. IN2) CALL CMWW( IR, I1, IN2, CB, NB, CB, NB,0) >*/
if (i1 <= in2) {
cmww_(&ir, &i1, &in2, &cb[cb_offset], nb, &cb[cb_offset],
nb, &c__0);
}
/* LOADING FOR B(WW)PRIME */
/*< >*/
if (im1 <= im2) {
cmws_(&ir, &im1, &im2, &cb[imx + cb_dim1], nb, &cb[
cb_offset], nb, &c__0);
}
/*< IF( NLODF.EQ.0) GOTO 19 >*/
if (zload_1.nlodf == 0) {
goto L19;
}
/*< JX= IR- ISV >*/
jx = ir - isv;
/*< IF( JX.LT.1.OR. JX.GT. IT) GOTO 19 >*/
if (jx < 1 || jx > it) {
goto L19;
}
/*< EXK= ZARRAY( IR) >*/
i__3 = ir - 1;
dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i =
zload_1.zarray[i__3].i;
/*< JSS= JCO(1) >*/
jss = segj_1.jco[0];
/*< CB( JX, JSS)= CB( JX, JSS)-( AX(1)+ CX(1))* EXK >*/
i__3 = jx + jss * cb_dim1;
i__2 = jx + jss * cb_dim1;
d__1 = segj_1.ax[0] + segj_1.cx[0];
z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
z__1.r = cb[i__2].r - z__2.r, z__1.i = cb[i__2].i - z__2.i;
cb[i__3].r = z__1.r, cb[i__3].i = z__1.i;
/*< 19 CONTINUE >*/
L19:
;
}
}
/*< 20 IF( NPCON.EQ.0) GOTO 22 >*/
L20:
if (segj_1.npcon == 0) {
goto L22;
}
/* FILL B(SS)PRIME TO SET OLD PATCH BASIS FUNCTIONS TO ZERO FOR */
/* PATCHES THAT CONNECT TO NEW SEGMENTS */
/*< JSS= NEQP >*/
jss = neqp;
/*< DO 21 I=1, NPCON >*/
i__5 = segj_1.npcon;
for (i = 1; i <= i__5; ++i) {
/*< IX= IPCON( I)*2+ N1- ISV >*/
ix = (segj_1.ipcon[i - 1] << 1) + data_1.n1 - isv;
/*< IR= IX-1 >*/
ir = ix - 1;
/*< JSS= JSS+1 >*/
++jss;
/*< IF( IR.GT.0.AND. IR.LE. IT) CB( IR, JSS)=(1.,0.) >*/
if (ir > 0 && ir <= it) {
i__4 = ir + jss * cb_dim1;
cb[i__4].r = 1., cb[i__4].i = 0.;
}
/*< JSS= JSS+1 >*/
++jss;
/*< IF( IX.GT.0.AND. IX.LE. IT) CB( IX, JSS)=(1.,0.) >*/
if (ix > 0 && ix <= it) {
i__4 = ix + jss * cb_dim1;
cb[i__4].r = 1., cb[i__4].i = 0.;
}
/*< 21 CONTINUE >*/
/* L21: */
}
/* FILL B(SW) AND B(SS) */
/*< 22 IF( M2.GT. M) GOTO 23 >*/
L22:
if (data_1.m2 > data_1.m) {
goto L23;
}
/*< >*/
if (i1 <= in2) {
cmsw_(&data_1.m2, &data_1.m, &i1, &in2, &cb[ist * cb_dim1 + 1], &
cb[cb_offset], &data_1.n1, nb, &c__0);
}
/*< >*/
if (im1 <= im2) {
cmss_(&data_1.m2, &data_1.m, &im1, &im2, &cb[imx + ist * cb_dim1],
nb, &c__0);
}
/*< 23 IF( ICASX.EQ.1) GOTO 24 >*/
L23:
if (matpar_1.icasx == 1) {
goto L24;
}
/*< WRITE( 14) (( CB( I, J), I=1, IT), J=1, ND) >*/
s_wsue(&io___256);
i__5 = *nd;
for (j = 1; j <= i__5; ++j) {
i__4 = it;
for (i = 1; i <= i__4; ++i) {
do_uio(&c__2, (char *)&cb[i + j * cb_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
/* FILLING B COMPLETE. START ON C AND D */
/*< 24 CONTINUE >*/
L24:
;
}
/*< IT= NPBL >*/
it = matpar_1.npbl;
/*< ISV=- NPBL >*/
isv = -matpar_1.npbl;
/*< DO 43 IBLK=1, NBBL >*/
i__1 = matpar_1.nbbl;
for (iblk = 1; iblk <= i__1; ++iblk) {
/*< ISV= ISV+ NPBL >*/
isv += matpar_1.npbl;
/*< ISVV= ISV+ NC >*/
isvv = isv + *nc;
/*< IF( IBLK.EQ. NBBL) IT= NLBL >*/
if (iblk == matpar_1.nbbl) {
it = matpar_1.nlbl;
}
/*< IF( ICASX.LT.3) GOTO 27 >*/
if (matpar_1.icasx < 3) {
goto L27;
}
/*< DO 26 J=1, IT >*/
i__4 = it;
for (j = 1; j <= i__4; ++j) {
/*< DO 25 I=1, NC >*/
i__5 = *nc;
for (i = 1; i <= i__5; ++i) {
/*< 25 CC( I, J)=(0.,0.) >*/
/* L25: */
i__3 = i + j * cc_dim1;
cc[i__3].r = 0., cc[i__3].i = 0.;
}
/*< DO 26 I=1, ND >*/
i__3 = *nd;
for (i = 1; i <= i__3; ++i) {
/*< 26 CD( I, J)=(0.,0.) >*/
/* L26: */
i__5 = i + j * cd_dim1;
cd[i__5].r = 0., cd[i__5].i = 0.;
}
}
/*< 27 I1= ISVV+1 >*/
L27:
i1 = isvv + 1;
/*< I2= ISVV+ IT >*/
i2 = isvv + it;
/*< IN1= I1- M1EQ >*/
in1 = i1 - m1eq;
/*< IN2= I2- M1EQ >*/
in2 = i2 - m1eq;
/*< IF( IN2.GT. N) IN2= N >*/
if (in2 > data_1.n) {
in2 = data_1.n;
}
/*< IM1= I1- N >*/
im1 = i1 - data_1.n;
/*< IM2= I2- N >*/
im2 = i2 - data_1.n;
/*< IF( IM1.LT. M2EQ) IM1= M2EQ >*/
if (im1 < m2eq) {
im1 = m2eq;
}
/*< IF( IM2.GT. MEQ) IM2= MEQ >*/
if (im2 > meq) {
im2 = meq;
}
/*< IMX=1 >*/
imx = 1;
/*< IF( IN1.LE. IN2) IMX= NEQN- I1+2 >*/
if (in1 <= in2) {
imx = neqn - i1 + 2;
}
/*< IF( ICASX.LT.3) GOTO 32 >*/
if (matpar_1.icasx < 3) {
goto L32;
}
/* SAME AS DO 24 LOOP TO FILL D(WW) FOR ICASX GREATER THAN 2 */
/*< IF( N2.GT. N) GOTO 32 >*/
if (data_1.n2 > data_1.n) {
goto L32;
}
/*< DO 31 J= N2, N >*/
i__5 = data_1.n;
for (j = data_1.n2; j <= i__5; ++j) {
/*< CALL TRIO( J) >*/
trio_(&j);
/*< DO 29 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< JSS= JCO( I) >*/
jss = segj_1.jco[i - 1];
/*< IF( JSS.LT. N2) GOTO 28 >*/
if (jss < data_1.n2) {
goto L28;
}
/*< JCO( I)= JSS- N1 >*/
segj_1.jco[i - 1] = jss - data_1.n1;
/*< GOTO 29 >*/
goto L29;
/*< 28 JCO( I)= NEQS+ ICONX( JSS) >*/
L28:
segj_1.jco[i - 1] = neqs + data_1.iconx[jss - 1];
/*< 29 CONTINUE >*/
L29:
;
}
/*< IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CD, ND, CD, ND,1) >*/
if (in1 <= in2) {
cmww_(&j, &in1, &in2, &cd[cd_offset], nd, &cd[cd_offset], nd,
&c__1);
}
/*< >*/
if (im1 <= im2) {
cmws_(&j, &im1, &im2, &cd[imx * cd_dim1 + 1], nd, &cd[
cd_offset], nd, &c__1);
}
/*< IF( NLOAD.EQ.0) GOTO 31 >*/
if (zload_1.nload == 0) {
goto L31;
}
/*< IR= J- N1- ISV >*/
ir = j - data_1.n1 - isv;
/*< IF( IR.LT.1.OR. IR.GT. IT) GOTO 31 >*/
if (ir < 1 || ir > it) {
goto L31;
}
/*< EXK= ZARRAY( J) >*/
i__3 = j - 1;
dataj_1.exk.r = zload_1.zarray[i__3].r, dataj_1.exk.i =
zload_1.zarray[i__3].i;
/*< DO 30 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< JSS= JCO( I) >*/
jss = segj_1.jco[i - 1];
/*< 30 CD( JSS, IR)= CD( JSS, IR)-( AX( I)+ CX( I))* EXK >*/
/* L30: */
i__4 = jss + ir * cd_dim1;
i__2 = jss + ir * cd_dim1;
d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
z__2.r = d__1 * dataj_1.exk.r, z__2.i = d__1 * dataj_1.exk.i;
z__1.r = cd[i__2].r - z__2.r, z__1.i = cd[i__2].i - z__2.i;
cd[i__4].r = z__1.r, cd[i__4].i = z__1.i;
}
/*< 31 CONTINUE >*/
L31:
;
}
/* FILL D(SW) AND D(SS) */
/*< 32 IF( M2.GT. M) GOTO 33 >*/
L32:
if (data_1.m2 > data_1.m) {
goto L33;
}
/*< >*/
if (in1 <= in2) {
cmsw_(&data_1.m2, &data_1.m, &in1, &in2, &cd[ist + cd_dim1], &cd[
cd_offset], &data_1.n1, nd, &c__1);
}
/*< >*/
if (im1 <= im2) {
cmss_(&data_1.m2, &data_1.m, &im1, &im2, &cd[ist + imx * cd_dim1],
nd, &c__1);
}
/* FILL C(WW),C(WS), D(WW)PRIME, AND D(WS)PRIME. */
/*< 33 IF( N1.LT.1) GOTO 39 >*/
L33:
if (data_1.n1 < 1) {
goto L39;
}
/*< DO 37 J=1, N1 >*/
i__5 = data_1.n1;
for (j = 1; j <= i__5; ++j) {
/*< CALL TRIO( J) >*/
trio_(&j);
/*< IF( NSCON.EQ.0) GOTO 36 >*/
if (segj_1.nscon == 0) {
goto L36;
}
/*< DO 35 IX=1, JSNO >*/
i__4 = segj_1.jsno;
for (ix = 1; ix <= i__4; ++ix) {
/*< JSS= JCO( IX) >*/
jss = segj_1.jco[ix - 1];
/*< IF( JSS.LT. N2) GOTO 34 >*/
if (jss < data_1.n2) {
goto L34;
}
/*< JCO( IX)= JSS+ M1EQ >*/
segj_1.jco[ix - 1] = jss + m1eq;
/*< GOTO 35 >*/
goto L35;
/*< 34 IR= ICONX( JSS) >*/
L34:
ir = data_1.iconx[jss - 1];
/*< IF( IR.NE.0) JCO( IX)= NEQSP+ IR >*/
if (ir != 0) {
segj_1.jco[ix - 1] = neqsp + ir;
}
/*< 35 CONTINUE >*/
L35:
;
}
/*< 36 IF( IN1.LE. IN2) CALL CMWW( J, IN1, IN2, CC, NC, CD, ND, ITX) >*/
L36:
if (in1 <= in2) {
cmww_(&j, &in1, &in2, &cc[cc_offset], nc, &cd[cd_offset], nd,
&itx);
}
/*< >*/
if (im1 <= im2) {
cmws_(&j, &im1, &im2, &cc[imx * cc_dim1 + 1], nc, &cd[imx *
cd_dim1 + 1], nd, &itx);
}
/*< 37 CONTINUE >*/
/* L37: */
}
/* FILL C(WW)PRIME */
/*< IF( NSCON.EQ.0) GOTO 39 >*/
if (segj_1.nscon == 0) {
goto L39;
}
/*< DO 38 IX=1, NSCON >*/
i__5 = segj_1.nscon;
for (ix = 1; ix <= i__5; ++ix) {
/*< IR= ISCON( IX) >*/
ir = segj_1.iscon[ix - 1];
/*< JSS= NEQS+ IX- ISV >*/
jss = neqs + ix - isv;
/*< IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.) >*/
if (jss > 0 && jss <= it) {
i__4 = ir + jss * cc_dim1;
cc[i__4].r = 1., cc[i__4].i = 0.;
}
/*< 38 CONTINUE >*/
/* L38: */
}
/*< 39 IF( NPCON.EQ.0) GOTO 41 >*/
L39:
if (segj_1.npcon == 0) {
goto L41;
}
/* FILL C(SS)PRIME */
/*< JSS= NEQP- ISV >*/
jss = neqp - isv;
/*< DO 40 I=1, NPCON >*/
i__5 = segj_1.npcon;
for (i = 1; i <= i__5; ++i) {
/*< IX= IPCON( I)*2+ N1 >*/
ix = (segj_1.ipcon[i - 1] << 1) + data_1.n1;
/*< IR= IX-1 >*/
ir = ix - 1;
/*< JSS= JSS+1 >*/
++jss;
/*< IF( JSS.GT.0.AND. JSS.LE. IT) CC( IR, JSS)=(1.,0.) >*/
if (jss > 0 && jss <= it) {
i__4 = ir + jss * cc_dim1;
cc[i__4].r = 1., cc[i__4].i = 0.;
}
/*< JSS= JSS+1 >*/
++jss;
/*< IF( JSS.GT.0.AND. JSS.LE. IT) CC( IX, JSS)=(1.,0.) >*/
if (jss > 0 && jss <= it) {
i__4 = ix + jss * cc_dim1;
cc[i__4].r = 1., cc[i__4].i = 0.;
}
/*< 40 CONTINUE >*/
/* L40: */
}
/* FILL C(SW) AND C(SS) */
/*< 41 IF( M1.LT.1) GOTO 42 >*/
L41:
if (data_1.m1 < 1) {
goto L42;
}
/*< >*/
if (in1 <= in2) {
cmsw_(&c__1, &data_1.m1, &in1, &in2, &cc[data_1.n2 + cc_dim1], &
cc[cc_offset], &c__0, nc, &c__1);
}
/*< IF( IM1.LE. IM2) CALL CMSS(1, M1, IM1, IM2, CC( N2, IMX), NC,1) >*/
if (im1 <= im2) {
cmss_(&c__1, &data_1.m1, &im1, &im2, &cc[data_1.n2 + imx *
cc_dim1], nc, &c__1);
}
/*< 42 CONTINUE >*/
L42:
/*< IF( ICASX.EQ.1) GOTO 43 >*/
if (matpar_1.icasx == 1) {
goto L43;
}
/*< WRITE( 12) (( CD( J, I), J=1, ND), I=1, IT) >*/
s_wsue(&io___259);
i__5 = it;
for (i = 1; i <= i__5; ++i) {
i__4 = *nd;
for (j = 1; j <= i__4; ++j) {
do_uio(&c__2, (char *)&cd[j + i * cd_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
/*< WRITE( 15) (( CC( J, I), J=1, NC), I=1, IT) >*/
s_wsue(&io___260);
i__4 = it;
for (i = 1; i <= i__4; ++i) {
i__5 = *nc;
for (j = 1; j <= i__5; ++j) {
do_uio(&c__2, (char *)&cc[j + i * cc_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
/*< 43 CONTINUE >*/
L43:
;
}
/*< IF( ICASX.EQ.1) RETURN >*/
if (matpar_1.icasx == 1) {
return 0;
}
/*< REWIND 12 >*/
al__1.aerr = 0;
al__1.aunit = 12;
f_rew(&al__1);
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< REWIND 15 >*/
al__1.aerr = 0;
al__1.aunit = 15;
f_rew(&al__1);
/*< RETURN >*/
return 0;
/*< END >*/
} /* cmngf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMSET( NROW, CM, RKHX, IEXKX) >*/
/* Subroutine */ int cmset_(nrow, cm, rkhx, iexkx)
integer *nrow;
doublecomplex *cm;
doublereal *rkhx;
integer *iexkx;
{
/* System generated locals */
integer cm_dim1, cm_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublereal d__1;
doublecomplex z__1, z__2;
alist al__1;
/* Builtin functions */
integer f_rew();
/* Local variables */
static integer npeq;
extern /* Subroutine */ int cmss_(), cmws_(), cmsw_(), trio_(), cmww_();
static integer iout, i, j, k;
static doublecomplex deter;
static integer i1, i2, ixblk1, ka, ij, kk, it;
extern /* Subroutine */ int blckot_();
static integer im1, in2, im2, jm1, jm2, mp2;
static doublecomplex zaj;
static integer neq, ipr, nop, isv, ist, jss, jst;
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* CMSET SETS UP THE COMPLEX STRUCTURE MATRIX IN THE ARRAY CM */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /SMAT/ SSX(16,16) >*/
/*< COMMON /SCRATM/ D( N2M) >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< >*/
/*< >*/
/*< DIMENSION CM( NROW,1) >*/
/*< MP2=2* MP >*/
/* Parameter adjustments */
cm_dim1 = *nrow;
cm_offset = cm_dim1 + 1;
cm -= cm_offset;
/* Function Body */
mp2 = data_1.mp << 1;
/*< NPEQ= NP+ MP2 >*/
npeq = data_1.np + mp2;
/*< NEQ= N+2* M >*/
neq = data_1.n + (data_1.m << 1);
/*< NOP= NEQ/ NPEQ >*/
nop = neq / npeq;
/*< IF( ICASE.GT.2) REWIND 11 >*/
if (matpar_1.icase > 2) {
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
}
/*< RKH= RKHX >*/
dataj_1.rkh = *rkhx;
/*< IEXK= IEXKX >*/
dataj_1.iexk = *iexkx;
/*< IOUT=2* NPBLK* NROW >*/
iout = (matpar_1.npblk << 1) * *nrow;
/* CYCLE OVER MATRIX BLOCKS */
/*< IT= NPBLK >*/
it = matpar_1.npblk;
/*< DO 13 IXBLK1=1, NBLOKS >*/
i__1 = matpar_1.nbloks;
for (ixblk1 = 1; ixblk1 <= i__1; ++ixblk1) {
/*< ISV=( IXBLK1-1)* NPBLK >*/
isv = (ixblk1 - 1) * matpar_1.npblk;
/*< IF( IXBLK1.EQ. NBLOKS) IT= NLAST >*/
if (ixblk1 == matpar_1.nbloks) {
it = matpar_1.nlast;
}
/*< DO 1 I=1, NROW >*/
i__2 = *nrow;
for (i = 1; i <= i__2; ++i) {
/*< DO 1 J=1, IT >*/
i__3 = it;
for (j = 1; j <= i__3; ++j) {
/*< 1 CM( I, J)=(0.,0.) >*/
/* L1: */
i__4 = i + j * cm_dim1;
cm[i__4].r = 0., cm[i__4].i = 0.;
}
}
/*< I1= ISV+1 >*/
i1 = isv + 1;
/*< I2= ISV+ IT >*/
i2 = isv + it;
/*< IN2= I2 >*/
in2 = i2;
/*< IF( IN2.GT. NP) IN2= NP >*/
if (in2 > data_1.np) {
in2 = data_1.np;
}
/*< IM1= I1- NP >*/
im1 = i1 - data_1.np;
/*< IM2= I2- NP >*/
im2 = i2 - data_1.np;
/*< IF( IM1.LT.1) IM1=1 >*/
if (im1 < 1) {
im1 = 1;
}
/*< IST=1 >*/
ist = 1;
/*< IF( I1.LE. NP) IST= NP- I1+2 >*/
if (i1 <= data_1.np) {
ist = data_1.np - i1 + 2;
}
/* WIRE SOURCE LOOP */
/*< IF( N.EQ.0) GOTO 5 >*/
if (data_1.n == 0) {
goto L5;
}
/*< DO 4 J=1, N >*/
i__4 = data_1.n;
for (j = 1; j <= i__4; ++j) {
/*< CALL TRIO( J) >*/
trio_(&j);
/*< DO 2 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< IJ= JCO( I) >*/
ij = segj_1.jco[i - 1];
/*< 2 JCO( I)=(( IJ-1)/ NP)* MP2+ IJ >*/
/* L2: */
segj_1.jco[i - 1] = (ij - 1) / data_1.np * mp2 + ij;
}
/*< IF( I1.LE. IN2) CALL CMWW( J, I1, IN2, CM, NROW, CM, NROW,1) >*/
if (i1 <= in2) {
cmww_(&j, &i1, &in2, &cm[cm_offset], nrow, &cm[cm_offset],
nrow, &c__1);
}
/*< >*/
if (im1 <= im2) {
cmws_(&j, &im1, &im2, &cm[ist * cm_dim1 + 1], nrow, &cm[
cm_offset], nrow, &c__1);
}
/* MATRIX ELEMENTS MODIFIED BY LOADING */
/*< IF( NLOAD.EQ.0) GOTO 4 >*/
if (zload_1.nload == 0) {
goto L4;
}
/*< IF( J.GT. NP) GOTO 4 >*/
if (j > data_1.np) {
goto L4;
}
/*< IPR= J- ISV >*/
ipr = j - isv;
/*< IF( IPR.LT.1.OR. IPR.GT. IT) GOTO 4 >*/
if (ipr < 1 || ipr > it) {
goto L4;
}
/*< ZAJ= ZARRAY( J) >*/
i__3 = j - 1;
zaj.r = zload_1.zarray[i__3].r, zaj.i = zload_1.zarray[i__3].i;
/*< DO 3 I=1, JSNO >*/
i__3 = segj_1.jsno;
for (i = 1; i <= i__3; ++i) {
/*< JSS= JCO( I) >*/
jss = segj_1.jco[i - 1];
/*< 3 CM( JSS, IPR)= CM( JSS, IPR)-( AX( I)+ CX( I))* ZAJ >*/
/* L3: */
i__2 = jss + ipr * cm_dim1;
i__5 = jss + ipr * cm_dim1;
d__1 = segj_1.ax[i - 1] + segj_1.cx[i - 1];
z__2.r = d__1 * zaj.r, z__2.i = d__1 * zaj.i;
z__1.r = cm[i__5].r - z__2.r, z__1.i = cm[i__5].i - z__2.i;
cm[i__2].r = z__1.r, cm[i__2].i = z__1.i;
}
/*< 4 CONTINUE >*/
L4:
;
}
/* MATRIX ELEMENTS FOR PATCH CURRENT SOURCES */
/*< 5 IF( M.EQ.0) GOTO 7 >*/
L5:
if (data_1.m == 0) {
goto L7;
}
/*< JM1=1- MP >*/
jm1 = 1 - data_1.mp;
/*< JM2=0 >*/
jm2 = 0;
/*< JST=1- MP2 >*/
jst = 1 - mp2;
/*< DO 6 I=1, NOP >*/
i__4 = nop;
for (i = 1; i <= i__4; ++i) {
/*< JM1= JM1+ MP >*/
jm1 += data_1.mp;
/*< JM2= JM2+ MP >*/
jm2 += data_1.mp;
/*< JST= JST+ NPEQ >*/
jst += npeq;
/*< >*/
if (i1 <= in2) {
cmsw_(&jm1, &jm2, &i1, &in2, &cm[jst + cm_dim1], &cm[
cm_offset], &c__0, nrow, &c__1);
}
/*< >*/
if (im1 <= im2) {
cmss_(&jm1, &jm2, &im1, &im2, &cm[jst + ist * cm_dim1], nrow,
&c__1);
}
/*< 6 CONTINUE >*/
/* L6: */
}
/*< 7 IF( ICASE.EQ.1) GOTO 13 >*/
L7:
if (matpar_1.icase == 1) {
goto L13;
}
/* COMBINE ELEMENTS FOR SYMMETRY MODES */
/*< IF( ICASE.EQ.3) GOTO 12 >*/
if (matpar_1.icase == 3) {
goto L12;
}
/*< DO 11 I=1, IT >*/
i__4 = it;
for (i = 1; i <= i__4; ++i) {
/*< DO 11 J=1, NPEQ >*/
i__2 = npeq;
for (j = 1; j <= i__2; ++j) {
/*< DO 8 K=1, NOP >*/
i__5 = nop;
for (k = 1; k <= i__5; ++k) {
/*< KA= J+( K-1)* NPEQ >*/
ka = j + (k - 1) * npeq;
/*< 8 D( K)= CM( KA, I) >*/
/* L8: */
i__3 = k - 1;
i__6 = ka + i * cm_dim1;
scratm_1.d[i__3].r = cm[i__6].r, scratm_1.d[i__3].i = cm[
i__6].i;
}
/*< DETER= D(1) >*/
deter.r = scratm_1.d[0].r, deter.i = scratm_1.d[0].i;
/*< DO 9 KK=2, NOP >*/
i__3 = nop;
for (kk = 2; kk <= i__3; ++kk) {
/*< 9 DETER= DETER+ D( KK) >*/
/* L9: */
i__6 = kk - 1;
z__1.r = deter.r + scratm_1.d[i__6].r, z__1.i = deter.i +
scratm_1.d[i__6].i;
deter.r = z__1.r, deter.i = z__1.i;
}
/*< CM( J, I)= DETER >*/
i__6 = j + i * cm_dim1;
cm[i__6].r = deter.r, cm[i__6].i = deter.i;
/*< DO 11 K=2, NOP >*/
i__6 = nop;
for (k = 2; k <= i__6; ++k) {
/*< KA= J+( K-1)* NPEQ >*/
ka = j + (k - 1) * npeq;
/*< DETER= D(1) >*/
deter.r = scratm_1.d[0].r, deter.i = scratm_1.d[0].i;
/*< DO 10 KK=2, NOP >*/
i__3 = nop;
for (kk = 2; kk <= i__3; ++kk) {
/*< 10 DETER= DETER+ D( KK)* SSX( K, KK) >*/
/* L10: */
i__5 = kk - 1;
i__7 = k + (kk << 4) - 17;
z__2.r = scratm_1.d[i__5].r * smat_1.ssx[i__7].r -
scratm_1.d[i__5].i * smat_1.ssx[i__7].i,
z__2.i = scratm_1.d[i__5].r * smat_1.ssx[i__7]
.i + scratm_1.d[i__5].i * smat_1.ssx[i__7].r;
z__1.r = deter.r + z__2.r, z__1.i = deter.i + z__2.i;
deter.r = z__1.r, deter.i = z__1.i;
}
/*< CM( KA, I)= DETER >*/
i__5 = ka + i * cm_dim1;
cm[i__5].r = deter.r, cm[i__5].i = deter.i;
/*< 11 CONTINUE >*/
/* L11: */
}
}
}
/* WRITE BLOCK FOR OUT-OF-CORE CASES. */
/*< IF( ICASE.LT.3) GOTO 13 >*/
if (matpar_1.icase < 3) {
goto L13;
}
/*< 12 CALL BLCKOT( CM,11,1, IOUT,1,31) >*/
L12:
blckot_(&cm[cm_offset], &c__11, &c__1, &iout, &c__1, &c__31);
/*< 13 CONTINUE >*/
L13:
;
}
/*< IF( ICASE.GT.2) REWIND 11 >*/
if (matpar_1.icase > 2) {
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* cmset_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMSS( J1, J2, IM1, IM2, CM, NROW, ITRP) >*/
/* Subroutine */ int cmss_(j1, j2, im1, im2, cm, nrow, itrp)
integer *j1, *j2, *im1, *im2;
doublecomplex *cm;
integer *nrow, *itrp;
{
/* System generated locals */
integer cm_dim1, cm_offset, i__1, i__2, i__3;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Local variables */
static doublereal t2yi, t2zi;
static integer i, j, icomp;
extern /* Subroutine */ int hintg_();
static integer i1, i2;
static doublecomplex g11, g12, g21, g22;
static integer il, jl;
static doublereal xi, yi, zi;
static integer ii1, ii2, jj1, jj2;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
static integer ldp;
static doublereal t1xi;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
static doublereal t1yi, t1zi, t2xi;
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* CMSS COMPUTES MATRIX ELEMENTS FOR SURFACE-SURFACE INTERACTIONS. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< DIMENSION CM( NROW,1) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< >*/
/*< >*/
/*< LDP= LD+1 >*/
/* Parameter adjustments */
cm_dim1 = *nrow;
cm_offset = cm_dim1 + 1;
cm -= cm_offset;
/* Function Body */
ldp = data_1.ld + 1;
/*< I1=( IM1+1)/2 >*/
i1 = (*im1 + 1) / 2;
/*< I2=( IM2+1)/2 >*/
i2 = (*im2 + 1) / 2;
/*< ICOMP= I1*2-3 >*/
icomp = (i1 << 1) - 3;
/*< II1=-1 >*/
ii1 = -1;
/* LOOP OVER OBSERVATION PATCHES */
/*< IF( ICOMP+2.LT. IM1) II1=-2 >*/
if (icomp + 2 < *im1) {
ii1 = -2;
}
/*< DO 5 I= I1, I2 >*/
i__1 = i2;
for (i = i1; i <= i__1; ++i) {
/*< IL= LDP- I >*/
il = ldp - i;
/*< ICOMP= ICOMP+2 >*/
icomp += 2;
/*< II1= II1+2 >*/
ii1 += 2;
/*< II2= II1+1 >*/
ii2 = ii1 + 1;
/*< T1XI= T1X( IL)* SALP( IL) >*/
t1xi = t1x[il - 1] * angl_1.salp[il - 1];
/*< T1YI= T1Y( IL)* SALP( IL) >*/
t1yi = t1y[il - 1] * angl_1.salp[il - 1];
/*< T1ZI= T1Z( IL)* SALP( IL) >*/
t1zi = t1z[il - 1] * angl_1.salp[il - 1];
/*< T2XI= T2X( IL)* SALP( IL) >*/
t2xi = t2x[il - 1] * angl_1.salp[il - 1];
/*< T2YI= T2Y( IL)* SALP( IL) >*/
t2yi = t2y[il - 1] * angl_1.salp[il - 1];
/*< T2ZI= T2Z( IL)* SALP( IL) >*/
t2zi = t2z[il - 1] * angl_1.salp[il - 1];
/*< XI= X( IL) >*/
xi = data_1.x[il - 1];
/*< YI= Y( IL) >*/
yi = data_1.y[il - 1];
/*< ZI= Z( IL) >*/
zi = data_1.z[il - 1];
/* LOOP OVER SOURCE PATCHES */
/*< JJ1=-1 >*/
jj1 = -1;
/*< DO 5 J= J1, J2 >*/
i__2 = *j2;
for (j = *j1; j <= i__2; ++j) {
/*< JL= LDP- J >*/
jl = ldp - j;
/*< JJ1= JJ1+2 >*/
jj1 += 2;
/*< JJ2= JJ1+1 >*/
jj2 = jj1 + 1;
/*< S= BI( JL) >*/
dataj_1.s = data_1.bi[jl - 1];
/*< XJ= X( JL) >*/
dataj_1.xj = data_1.x[jl - 1];
/*< YJ= Y( JL) >*/
dataj_1.yj = data_1.y[jl - 1];
/*< ZJ= Z( JL) >*/
dataj_1.zj = data_1.z[jl - 1];
/*< T1XJ= T1X( JL) >*/
*t1xj = t1x[jl - 1];
/*< T1YJ= T1Y( JL) >*/
*t1yj = t1y[jl - 1];
/*< T1ZJ= T1Z( JL) >*/
*t1zj = t1z[jl - 1];
/*< T2XJ= T2X( JL) >*/
*t2xj = t2x[jl - 1];
/*< T2YJ= T2Y( JL) >*/
*t2yj = t2y[jl - 1];
/*< T2ZJ= T2Z( JL) >*/
*t2zj = t2z[jl - 1];
/*< CALL HINTG( XI, YI, ZI) >*/
hintg_(&xi, &yi, &zi);
/*< G11=-( T2XI* EXK+ T2YI* EYK+ T2ZI* EZK) >*/
z__4.r = t2xi * dataj_1.exk.r, z__4.i = t2xi * dataj_1.exk.i;
z__5.r = t2yi * dataj_1.eyk.r, z__5.i = t2yi * dataj_1.eyk.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = t2zi * dataj_1.ezk.r, z__6.i = t2zi * dataj_1.ezk.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
g11.r = z__1.r, g11.i = z__1.i;
/*< G12=-( T2XI* EXS+ T2YI* EYS+ T2ZI* EZS) >*/
z__4.r = t2xi * dataj_1.exs.r, z__4.i = t2xi * dataj_1.exs.i;
z__5.r = t2yi * dataj_1.eys.r, z__5.i = t2yi * dataj_1.eys.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = t2zi * dataj_1.ezs.r, z__6.i = t2zi * dataj_1.ezs.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
g12.r = z__1.r, g12.i = z__1.i;
/*< G21=-( T1XI* EXK+ T1YI* EYK+ T1ZI* EZK) >*/
z__4.r = t1xi * dataj_1.exk.r, z__4.i = t1xi * dataj_1.exk.i;
z__5.r = t1yi * dataj_1.eyk.r, z__5.i = t1yi * dataj_1.eyk.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = t1zi * dataj_1.ezk.r, z__6.i = t1zi * dataj_1.ezk.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
g21.r = z__1.r, g21.i = z__1.i;
/*< G22=-( T1XI* EXS+ T1YI* EYS+ T1ZI* EZS) >*/
z__4.r = t1xi * dataj_1.exs.r, z__4.i = t1xi * dataj_1.exs.i;
z__5.r = t1yi * dataj_1.eys.r, z__5.i = t1yi * dataj_1.eys.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = t1zi * dataj_1.ezs.r, z__6.i = t1zi * dataj_1.ezs.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
g22.r = z__1.r, g22.i = z__1.i;
/*< IF( I.NE. J) GOTO 1 >*/
if (i != j) {
goto L1;
}
/*< G11= G11-.5 >*/
z__1.r = g11.r - .5, z__1.i = g11.i;
g11.r = z__1.r, g11.i = z__1.i;
/*< G22= G22+.5 >*/
z__1.r = g22.r + .5, z__1.i = g22.i;
g22.r = z__1.r, g22.i = z__1.i;
/* NORMAL FILL */
/*< 1 IF( ITRP.NE.0) GOTO 3 >*/
L1:
if (*itrp != 0) {
goto L3;
}
/*< IF( ICOMP.LT. IM1) GOTO 2 >*/
if (icomp < *im1) {
goto L2;
}
/*< CM( II1, JJ1)= G11 >*/
i__3 = ii1 + jj1 * cm_dim1;
cm[i__3].r = g11.r, cm[i__3].i = g11.i;
/*< CM( II1, JJ2)= G12 >*/
i__3 = ii1 + jj2 * cm_dim1;
cm[i__3].r = g12.r, cm[i__3].i = g12.i;
/*< 2 IF( ICOMP.GE. IM2) GOTO 5 >*/
L2:
if (icomp >= *im2) {
goto L5;
}
/*< CM( II2, JJ1)= G21 >*/
i__3 = ii2 + jj1 * cm_dim1;
cm[i__3].r = g21.r, cm[i__3].i = g21.i;
/*< CM( II2, JJ2)= G22 >*/
i__3 = ii2 + jj2 * cm_dim1;
cm[i__3].r = g22.r, cm[i__3].i = g22.i;
/* TRANSPOSED FILL */
/*< GOTO 5 >*/
goto L5;
/*< 3 IF( ICOMP.LT. IM1) GOTO 4 >*/
L3:
if (icomp < *im1) {
goto L4;
}
/*< CM( JJ1, II1)= G11 >*/
i__3 = jj1 + ii1 * cm_dim1;
cm[i__3].r = g11.r, cm[i__3].i = g11.i;
/*< CM( JJ2, II1)= G12 >*/
i__3 = jj2 + ii1 * cm_dim1;
cm[i__3].r = g12.r, cm[i__3].i = g12.i;
/*< 4 IF( ICOMP.GE. IM2) GOTO 5 >*/
L4:
if (icomp >= *im2) {
goto L5;
}
/*< CM( JJ1, II2)= G21 >*/
i__3 = jj1 + ii2 * cm_dim1;
cm[i__3].r = g21.r, cm[i__3].i = g21.i;
/*< CM( JJ2, II2)= G22 >*/
i__3 = jj2 + ii2 * cm_dim1;
cm[i__3].r = g22.r, cm[i__3].i = g22.i;
/*< 5 CONTINUE >*/
L5:
;
}
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* cmss_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMSW( J1, J2, I1, I2, CM, CW, NCW, NROW, ITRP) >*/
/* Subroutine */ int cmsw_(j1, j2, i1, i2, cm, cw, ncw, nrow, itrp)
integer *j1, *j2, *i1, *i2;
doublecomplex *cm, *cw;
integer *ncw, *nrow, *itrp;
{
/* Initialized data */
static doublereal pi = 3.141592654;
/* System generated locals */
integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4,
i__5;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sin(), cos();
/* Local variables */
static doublereal sabi;
static doublecomplex emel[9];
static integer icgo, ipch, neqs;
extern /* Subroutine */ int trio_();
static integer i, j, k;
static doublereal fsign, salpi;
extern /* Subroutine */ int pcint_(), unere_();
static integer il, jl;
static doublereal xi, yi, zi;
static integer js, ip;
static doublereal py, px;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static integer ldp;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
static doublereal cabi;
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* COMPUTES MATRIX ELEMENTS FOR E ALONG WIRES DUE TO PATCH CURRENT */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< >*/
/*< DIMENSION CAB(1), SAB(1), CM( NROW,1), CW( NROW,1) >*/
/*< >*/
/*< >*/
/*< >*/
/*< DATA PI/3.141592654D+0/ >*/
/* Parameter adjustments */
cw_dim1 = *nrow;
cw_offset = cw_dim1 + 1;
cw -= cw_offset;
cm_dim1 = *nrow;
cm_offset = cm_dim1 + 1;
cm -= cm_offset;
/* Function Body */
/*< LDP= LD+1 >*/
ldp = data_1.ld + 1;
/*< NEQS= N- N1+2*( M- M1) >*/
neqs = data_1.n - data_1.n1 + (data_1.m - data_1.m1 << 1);
/*< IF( ITRP.LT.0) GOTO 13 >*/
if (*itrp < 0) {
goto L13;
}
/*< K=0 >*/
k = 0;
/* OBSERVATION LOOP */
/*< ICGO=1 >*/
icgo = 1;
/*< DO 12 I= I1, I2 >*/
i__1 = *i2;
for (i = *i1; i <= i__1; ++i) {
/*< K= K+1 >*/
++k;
/*< XI= X( I) >*/
xi = data_1.x[i - 1];
/*< YI= Y( I) >*/
yi = data_1.y[i - 1];
/*< ZI= Z( I) >*/
zi = data_1.z[i - 1];
/*< CABI= CAB( I) >*/
cabi = cab[i - 1];
/*< SABI= SAB( I) >*/
sabi = sab[i - 1];
/*< SALPI= SALP( I) >*/
salpi = angl_1.salp[i - 1];
/*< IPCH=0 >*/
ipch = 0;
/*< IF( ICON1( I).LT.10000) GOTO 1 >*/
if (data_1.icon1[i - 1] < 10000) {
goto L1;
}
/*< IPCH= ICON1( I)-10000 >*/
ipch = data_1.icon1[i - 1] - 10000;
/*< FSIGN=-1. >*/
fsign = -1.;
/*< 1 IF( ICON2( I).LT.10000) GOTO 2 >*/
L1:
if (data_1.icon2[i - 1] < 10000) {
goto L2;
}
/*< IPCH= ICON2( I)-10000 >*/
ipch = data_1.icon2[i - 1] - 10000;
/*< FSIGN=1. >*/
fsign = 1.;
/* SOURCE LOOP */
/*< 2 JL=0 >*/
L2:
jl = 0;
/*< DO 12 J= J1, J2 >*/
i__2 = *j2;
for (j = *j1; j <= i__2; ++j) {
/*< JS= LDP- J >*/
js = ldp - j;
/*< JL= JL+2 >*/
jl += 2;
/*< T1XJ= T1X( JS) >*/
*t1xj = t1x[js - 1];
/*< T1YJ= T1Y( JS) >*/
*t1yj = t1y[js - 1];
/*< T1ZJ= T1Z( JS) >*/
*t1zj = t1z[js - 1];
/*< T2XJ= T2X( JS) >*/
*t2xj = t2x[js - 1];
/*< T2YJ= T2Y( JS) >*/
*t2yj = t2y[js - 1];
/*< T2ZJ= T2Z( JS) >*/
*t2zj = t2z[js - 1];
/*< XJ= X( JS) >*/
dataj_1.xj = data_1.x[js - 1];
/*< YJ= Y( JS) >*/
dataj_1.yj = data_1.y[js - 1];
/*< ZJ= Z( JS) >*/
dataj_1.zj = data_1.z[js - 1];
/* GROUND LOOP */
/*< S= BI( JS) >*/
dataj_1.s = data_1.bi[js - 1];
/*< DO 12 IP=1, KSYMP >*/
i__3 = gnd_1.ksymp;
for (ip = 1; ip <= i__3; ++ip) {
/*< IPGND= IP >*/
dataj_1.ipgnd = ip;
/*< IF( IPCH.NE. J.AND. ICGO.EQ.1) GOTO 9 >*/
if (ipch != j && icgo == 1) {
goto L9;
}
/*< IF( IP.EQ.2) GOTO 9 >*/
if (ip == 2) {
goto L9;
}
/*< IF( ICGO.GT.1) GOTO 6 >*/
if (icgo > 1) {
goto L6;
}
/*< CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL) >*/
pcint_(&xi, &yi, &zi, &cabi, &sabi, &salpi, emel);
/*< PY= PI* SI( I)* FSIGN >*/
d__1 = pi * data_1.si[i - 1];
py = d__1 * fsign;
/*< PX= SIN( PY) >*/
px = sin(py);
/*< PY= COS( PY) >*/
py = cos(py);
/*< EXC= EMEL(9)* FSIGN >*/
z__1.r = fsign * emel[8].r, z__1.i = fsign * emel[8].i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< CALL TRIO( I) >*/
trio_(&i);
/*< IF( I.GT. N1) GOTO 3 >*/
if (i > data_1.n1) {
goto L3;
}
/*< IL= NEQS+ ICONX( I) >*/
il = neqs + data_1.iconx[i - 1];
/*< GOTO 4 >*/
goto L4;
/*< 3 IL= I- NCW >*/
L3:
il = i - *ncw;
/*< IF( I.LE. NP) IL=(( IL-1)/ NP)*2* MP+ IL >*/
if (i <= data_1.np) {
il = ((il - 1) / data_1.np << 1) * data_1.mp + il;
}
/*< 4 IF( ITRP.NE.0) GOTO 5 >*/
L4:
if (*itrp != 0) {
goto L5;
}
/*< >*/
i__4 = k + il * cw_dim1;
i__5 = k + il * cw_dim1;
d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1]
* px;
d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
z__1.r = cw[i__5].r + z__2.r, z__1.i = cw[i__5].i + z__2.i;
cw[i__4].r = z__1.r, cw[i__4].i = z__1.i;
/*< GOTO 6 >*/
goto L6;
/*< >*/
L5:
i__4 = il + k * cw_dim1;
i__5 = il + k * cw_dim1;
d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1]
* px;
d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
z__1.r = cw[i__5].r + z__2.r, z__1.i = cw[i__5].i + z__2.i;
cw[i__4].r = z__1.r, cw[i__4].i = z__1.i;
/*< 6 IF( ITRP.NE.0) GOTO 7 >*/
L6:
if (*itrp != 0) {
goto L7;
}
/*< CM( K, JL-1)= EMEL( ICGO) >*/
i__4 = k + (jl - 1) * cm_dim1;
i__5 = icgo - 1;
cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
/*< CM( K, JL)= EMEL( ICGO+4) >*/
i__4 = k + jl * cm_dim1;
i__5 = icgo + 3;
cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
/*< GOTO 8 >*/
goto L8;
/*< 7 CM( JL-1, K)= EMEL( ICGO) >*/
L7:
i__4 = jl - 1 + k * cm_dim1;
i__5 = icgo - 1;
cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
/*< CM( JL, K)= EMEL( ICGO+4) >*/
i__4 = jl + k * cm_dim1;
i__5 = icgo + 3;
cm[i__4].r = emel[i__5].r, cm[i__4].i = emel[i__5].i;
/*< 8 ICGO= ICGO+1 >*/
L8:
++icgo;
/*< IF( ICGO.EQ.5) ICGO=1 >*/
if (icgo == 5) {
icgo = 1;
}
/*< GOTO 11 >*/
goto L11;
/*< 9 CALL UNERE( XI, YI, ZI) >*/
L9:
unere_(&xi, &yi, &zi);
/* NORMAL FILL */
/*< IF( ITRP.NE.0) GOTO 10 >*/
if (*itrp != 0) {
goto L10;
}
/*< CM( K, JL-1)= CM( K, JL-1)+ EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
i__4 = k + (jl - 1) * cm_dim1;
i__5 = k + (jl - 1) * cm_dim1;
z__4.r = cabi * dataj_1.exk.r, z__4.i = cabi * dataj_1.exk.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
z__5.r = sabi * dataj_1.eyk.r, z__5.i = sabi * dataj_1.eyk.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = salpi * dataj_1.ezk.r, z__6.i = salpi *
dataj_1.ezk.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
/*< CM( K, JL)= CM( K, JL)+ EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
i__4 = k + jl * cm_dim1;
i__5 = k + jl * cm_dim1;
z__4.r = cabi * dataj_1.exs.r, z__4.i = cabi * dataj_1.exs.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
z__5.r = sabi * dataj_1.eys.r, z__5.i = sabi * dataj_1.eys.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = salpi * dataj_1.ezs.r, z__6.i = salpi *
dataj_1.ezs.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
/* TRANSPOSED FILL */
/*< GOTO 11 >*/
goto L11;
/*< 10 CM( JL-1, K)= CM( JL-1, K)+ EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
L10:
i__4 = jl - 1 + k * cm_dim1;
i__5 = jl - 1 + k * cm_dim1;
z__4.r = cabi * dataj_1.exk.r, z__4.i = cabi * dataj_1.exk.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
z__5.r = sabi * dataj_1.eyk.r, z__5.i = sabi * dataj_1.eyk.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = salpi * dataj_1.ezk.r, z__6.i = salpi *
dataj_1.ezk.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
/*< CM( JL, K)= CM( JL, K)+ EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
i__4 = jl + k * cm_dim1;
i__5 = jl + k * cm_dim1;
z__4.r = cabi * dataj_1.exs.r, z__4.i = cabi * dataj_1.exs.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
z__5.r = sabi * dataj_1.eys.r, z__5.i = sabi * dataj_1.eys.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = salpi * dataj_1.ezs.r, z__6.i = salpi *
dataj_1.ezs.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
/*< 11 CONTINUE >*/
L11:
/*< 12 CONTINUE >*/
/* L12: */
;
}
}
}
/* FOR OLD SEG. CONNECTING TO OLD PATCH ON ONE END AND NEW SEG. ON */
/* OTHER END INTEGRATE SINGULAR COMPONENT (9) OF SURFACE CURRENT ONLY
*/
/*< RETURN >*/
return 0;
/*< 13 IF( J1.LT. I1.OR. J1.GT. I2) GOTO 16 >*/
L13:
if (*j1 < *i1 || *j1 > *i2) {
goto L16;
}
/*< IPCH= ICON1( J1) >*/
ipch = data_1.icon1[*j1 - 1];
/*< IF( IPCH.LT.10000) GOTO 14 >*/
if (ipch < 10000) {
goto L14;
}
/*< IPCH= IPCH-10000 >*/
ipch += -10000;
/*< FSIGN=-1. >*/
fsign = -1.;
/*< GOTO 15 >*/
goto L15;
/*< 14 IPCH= ICON2( J1) >*/
L14:
ipch = data_1.icon2[*j1 - 1];
/*< IF( IPCH.LT.10000) GOTO 16 >*/
if (ipch < 10000) {
goto L16;
}
/*< IPCH= IPCH-10000 >*/
ipch += -10000;
/*< FSIGN=1. >*/
fsign = 1.;
/*< 15 IF( IPCH.GT. M1) GOTO 16 >*/
L15:
if (ipch > data_1.m1) {
goto L16;
}
/*< JS= LDP- IPCH >*/
js = ldp - ipch;
/*< IPGND=1 >*/
dataj_1.ipgnd = 1;
/*< T1XJ= T1X( JS) >*/
*t1xj = t1x[js - 1];
/*< T1YJ= T1Y( JS) >*/
*t1yj = t1y[js - 1];
/*< T1ZJ= T1Z( JS) >*/
*t1zj = t1z[js - 1];
/*< T2XJ= T2X( JS) >*/
*t2xj = t2x[js - 1];
/*< T2YJ= T2Y( JS) >*/
*t2yj = t2y[js - 1];
/*< T2ZJ= T2Z( JS) >*/
*t2zj = t2z[js - 1];
/*< XJ= X( JS) >*/
dataj_1.xj = data_1.x[js - 1];
/*< YJ= Y( JS) >*/
dataj_1.yj = data_1.y[js - 1];
/*< ZJ= Z( JS) >*/
dataj_1.zj = data_1.z[js - 1];
/*< S= BI( JS) >*/
dataj_1.s = data_1.bi[js - 1];
/*< XI= X( J1) >*/
xi = data_1.x[*j1 - 1];
/*< YI= Y( J1) >*/
yi = data_1.y[*j1 - 1];
/*< ZI= Z( J1) >*/
zi = data_1.z[*j1 - 1];
/*< CABI= CAB( J1) >*/
cabi = cab[*j1 - 1];
/*< SABI= SAB( J1) >*/
sabi = sab[*j1 - 1];
/*< SALPI= SALP( J1) >*/
salpi = angl_1.salp[*j1 - 1];
/*< CALL PCINT( XI, YI, ZI, CABI, SABI, SALPI, EMEL) >*/
pcint_(&xi, &yi, &zi, &cabi, &sabi, &salpi, emel);
/*< PY= PI* SI( J1)* FSIGN >*/
d__1 = pi * data_1.si[*j1 - 1];
py = d__1 * fsign;
/*< PX= SIN( PY) >*/
px = sin(py);
/*< PY= COS( PY) >*/
py = cos(py);
/*< EXC= EMEL(9)* FSIGN >*/
z__1.r = fsign * emel[8].r, z__1.i = fsign * emel[8].i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< IL= JCO( JSNO) >*/
il = segj_1.jco[segj_1.jsno - 1];
/*< K= J1- I1+1 >*/
k = *j1 - *i1 + 1;
/*< >*/
i__3 = k + il * cw_dim1;
i__2 = k + il * cw_dim1;
d__2 = segj_1.ax[segj_1.jsno - 1] + segj_1.bx[segj_1.jsno - 1] * px;
d__1 = d__2 + segj_1.cx[segj_1.jsno - 1] * py;
z__2.r = d__1 * dataj_1.exc.r, z__2.i = d__1 * dataj_1.exc.i;
z__1.r = cw[i__2].r + z__2.r, z__1.i = cw[i__2].i + z__2.i;
cw[i__3].r = z__1.r, cw[i__3].i = z__1.i;
/*< 16 RETURN >*/
L16:
return 0;
/*< END >*/
} /* cmsw_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMWS( J, I1, I2, CM, NR, CW, NW, ITRP) >*/
/* Subroutine */ int cmws_(j, i1, i2, cm, nr, cw, nw, itrp)
integer *j, *i1, *i2;
doublecomplex *cm;
integer *nr;
doublecomplex *cw;
integer *nw, *itrp;
{
/* System generated locals */
integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4,
i__5, i__6, i__7;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Local variables */
static integer i;
extern /* Subroutine */ int hsfld_();
static integer ij, ik, js;
static doublereal xi;
static integer ipatch;
static doublereal yi, zi;
static integer jx;
static doublereal tx, ty, tz;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex etc;
static integer ldp;
static doublecomplex etk;
static integer ipr;
static doublecomplex ets;
/* *** */
/* CMWS COMPUTES MATRIX ELEMENTS FOR WIRE-SURFACE INTERACTIONS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< DIMENSION CM( NR,1), CW( NW,1), CAB(1), SAB(1) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET),(T1X,SI),(T1Y,ALP),(T1Z,BET) >*/
/*< EQUIVALENCE(T2X,ICON1),(T2Y,ICON2),(T2Z,ITAG) >*/
/*< LDP= LD+1 >*/
/* Parameter adjustments */
cw_dim1 = *nw;
cw_offset = cw_dim1 + 1;
cw -= cw_offset;
cm_dim1 = *nr;
cm_offset = cm_dim1 + 1;
cm -= cm_offset;
/* Function Body */
ldp = data_1.ld + 1;
/*< S= SI( J) >*/
dataj_1.s = data_1.si[*j - 1];
/*< B= BI( J) >*/
dataj_1.b = data_1.bi[*j - 1];
/*< XJ= X( J) >*/
dataj_1.xj = data_1.x[*j - 1];
/*< YJ= Y( J) >*/
dataj_1.yj = data_1.y[*j - 1];
/*< ZJ= Z( J) >*/
dataj_1.zj = data_1.z[*j - 1];
/*< CABJ= CAB( J) >*/
dataj_1.cabj = cab[*j - 1];
/*< SABJ= SAB( J) >*/
dataj_1.sabj = sab[*j - 1];
/* OBSERVATION LOOP */
/*< SALPJ= SALP( J) >*/
dataj_1.salpj = angl_1.salp[*j - 1];
/*< IPR=0 >*/
ipr = 0;
/*< DO 9 I= I1, I2 >*/
i__1 = *i2;
for (i = *i1; i <= i__1; ++i) {
/*< IPR= IPR+1 >*/
++ipr;
/*< IPATCH=( I+1)/2 >*/
ipatch = (i + 1) / 2;
/*< IK= I-( I/2)*2 >*/
ik = i - (i / 2 << 1);
/*< IF( IK.EQ.0.AND. IPR.NE.1) GOTO 1 >*/
if (ik == 0 && ipr != 1) {
goto L1;
}
/*< JS= LDP- IPATCH >*/
js = ldp - ipatch;
/*< XI= X( JS) >*/
xi = data_1.x[js - 1];
/*< YI= Y( JS) >*/
yi = data_1.y[js - 1];
/*< ZI= Z( JS) >*/
zi = data_1.z[js - 1];
/*< CALL HSFLD( XI, YI, ZI,0.) >*/
hsfld_(&xi, &yi, &zi, &c_b594);
/*< IF( IK.EQ.0) GOTO 1 >*/
if (ik == 0) {
goto L1;
}
/*< TX= T2X( JS) >*/
tx = t2x[js - 1];
/*< TY= T2Y( JS) >*/
ty = t2y[js - 1];
/*< TZ= T2Z( JS) >*/
tz = t2z[js - 1];
/*< GOTO 2 >*/
goto L2;
/*< 1 TX= T1X( JS) >*/
L1:
tx = t1x[js - 1];
/*< TY= T1Y( JS) >*/
ty = t1y[js - 1];
/*< TZ= T1Z( JS) >*/
tz = t1z[js - 1];
/*< 2 ETK=-( EXK* TX+ EYK* TY+ EZK* TZ)* SALP( JS) >*/
L2:
z__5.r = tx * dataj_1.exk.r, z__5.i = tx * dataj_1.exk.i;
z__6.r = ty * dataj_1.eyk.r, z__6.i = ty * dataj_1.eyk.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__7.r = tz * dataj_1.ezk.r, z__7.i = tz * dataj_1.ezk.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
i__2 = js - 1;
z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] *
z__2.i;
etk.r = z__1.r, etk.i = z__1.i;
/*< ETS=-( EXS* TX+ EYS* TY+ EZS* TZ)* SALP( JS) >*/
z__5.r = tx * dataj_1.exs.r, z__5.i = tx * dataj_1.exs.i;
z__6.r = ty * dataj_1.eys.r, z__6.i = ty * dataj_1.eys.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__7.r = tz * dataj_1.ezs.r, z__7.i = tz * dataj_1.ezs.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
i__2 = js - 1;
z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] *
z__2.i;
ets.r = z__1.r, ets.i = z__1.i;
/* FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTI
ON */
/* DATA. */
/*< ETC=-( EXC* TX+ EYC* TY+ EZC* TZ)* SALP( JS) >*/
z__5.r = tx * dataj_1.exc.r, z__5.i = tx * dataj_1.exc.i;
z__6.r = ty * dataj_1.eyc.r, z__6.i = ty * dataj_1.eyc.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__7.r = tz * dataj_1.ezc.r, z__7.i = tz * dataj_1.ezc.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
i__2 = js - 1;
z__1.r = angl_1.salp[i__2] * z__2.r, z__1.i = angl_1.salp[i__2] *
z__2.i;
etc.r = z__1.r, etc.i = z__1.i;
/* NORMAL FILL */
/*< IF( ITRP.NE.0) GOTO 4 >*/
if (*itrp != 0) {
goto L4;
}
/*< DO 3 IJ=1, JSNO >*/
i__2 = segj_1.jsno;
for (ij = 1; ij <= i__2; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< >*/
/* L3: */
i__3 = ipr + jx * cm_dim1;
i__4 = ipr + jx * cm_dim1;
i__5 = ij - 1;
z__4.r = segj_1.ax[i__5] * etk.r, z__4.i = segj_1.ax[i__5] *
etk.i;
z__3.r = cm[i__4].r + z__4.r, z__3.i = cm[i__4].i + z__4.i;
i__6 = ij - 1;
z__5.r = segj_1.bx[i__6] * ets.r, z__5.i = segj_1.bx[i__6] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__7 = ij - 1;
z__6.r = segj_1.cx[i__7] * etc.r, z__6.i = segj_1.cx[i__7] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__3].r = z__1.r, cm[i__3].i = z__1.i;
}
/*< GOTO 9 >*/
goto L9;
/* TRANSPOSED FILL */
/*< 4 IF( ITRP.EQ.2) GOTO 6 >*/
L4:
if (*itrp == 2) {
goto L6;
}
/*< DO 5 IJ=1, JSNO >*/
i__3 = segj_1.jsno;
for (ij = 1; ij <= i__3; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< >*/
/* L5: */
i__4 = jx + ipr * cm_dim1;
i__5 = jx + ipr * cm_dim1;
i__6 = ij - 1;
z__4.r = segj_1.ax[i__6] * etk.r, z__4.i = segj_1.ax[i__6] *
etk.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
i__7 = ij - 1;
z__5.r = segj_1.bx[i__7] * ets.r, z__5.i = segj_1.bx[i__7] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__2 = ij - 1;
z__6.r = segj_1.cx[i__2] * etc.r, z__6.i = segj_1.cx[i__2] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
}
/* TRANSPOSED FILL - C(WS) AND D(WS)PRIME (=CW) */
/*< GOTO 9 >*/
goto L9;
/*< 6 DO 8 IJ=1, JSNO >*/
L6:
i__4 = segj_1.jsno;
for (ij = 1; ij <= i__4; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< IF( JX.GT. NR) GOTO 7 >*/
if (jx > *nr) {
goto L7;
}
/*< >*/
i__5 = jx + ipr * cm_dim1;
i__6 = jx + ipr * cm_dim1;
i__7 = ij - 1;
z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] *
etk.i;
z__3.r = cm[i__6].r + z__4.r, z__3.i = cm[i__6].i + z__4.i;
i__2 = ij - 1;
z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__3 = ij - 1;
z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__5].r = z__1.r, cm[i__5].i = z__1.i;
/*< GOTO 8 >*/
goto L8;
/*< 7 JX= JX- NR >*/
L7:
jx -= *nr;
/*< >*/
i__5 = jx + ipr * cw_dim1;
i__6 = jx + ipr * cw_dim1;
i__7 = ij - 1;
z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] *
etk.i;
z__3.r = cw[i__6].r + z__4.r, z__3.i = cw[i__6].i + z__4.i;
i__2 = ij - 1;
z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__3 = ij - 1;
z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cw[i__5].r = z__1.r, cw[i__5].i = z__1.i;
/*< 8 CONTINUE >*/
L8:
;
}
/*< 9 CONTINUE >*/
L9:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* cmws_ */
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CMWW( J, I1, I2, CM, NR, CW, NW, ITRP) >*/
/* Subroutine */ int cmww_(j, i1, i2, cm, nr, cw, nw, itrp)
integer *j, *i1, *i2;
doublecomplex *cm;
integer *nr;
doublecomplex *cw;
integer *nw, *itrp;
{
/* System generated locals */
integer cm_dim1, cm_offset, cw_dim1, cw_offset, i__1, i__2, i__3, i__4,
i__5, i__6, i__7;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Local variables */
extern /* Subroutine */ int efld_();
static doublereal sabi;
static integer i;
static doublereal salpi, ai;
static integer ij;
static doublereal xi, yi, zi;
static integer jx;
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex etc, etk;
static integer ipr;
static doublecomplex ets;
static doublereal cabi;
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* CMWW COMPUTES MATRIX ELEMENTS FOR WIRE-WIRE INTERACTIONS */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< DIMENSION CM( NR,1), CW( NW,1), CAB(1), SAB(1) >*/
/* SET SOURCE SEGMENT PARAMETERS */
/*< EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
/*< S= SI( J) >*/
/* Parameter adjustments */
cw_dim1 = *nw;
cw_offset = cw_dim1 + 1;
cw -= cw_offset;
cm_dim1 = *nr;
cm_offset = cm_dim1 + 1;
cm -= cm_offset;
/* Function Body */
dataj_1.s = data_1.si[*j - 1];
/*< B= BI( J) >*/
dataj_1.b = data_1.bi[*j - 1];
/*< XJ= X( J) >*/
dataj_1.xj = data_1.x[*j - 1];
/*< YJ= Y( J) >*/
dataj_1.yj = data_1.y[*j - 1];
/*< ZJ= Z( J) >*/
dataj_1.zj = data_1.z[*j - 1];
/*< CABJ= CAB( J) >*/
dataj_1.cabj = cab[*j - 1];
/*< SABJ= SAB( J) >*/
dataj_1.sabj = sab[*j - 1];
/*< SALPJ= SALP( J) >*/
dataj_1.salpj = angl_1.salp[*j - 1];
/* DECIDE WETHER EXT. T.W. APPROX. CAN BE USED */
/*< IF( IEXK.EQ.0) GOTO 16 >*/
if (dataj_1.iexk == 0) {
goto L16;
}
/*< IPR= ICON1( J) >*/
ipr = data_1.icon1[*j - 1];
/*< IF( IPR) 1,6,2 >*/
if (ipr < 0) {
goto L1;
} else if (ipr == 0) {
goto L6;
} else {
goto L2;
}
/*< 1 IPR=- IPR >*/
L1:
ipr = -ipr;
/*< IF(- ICON1( IPR).NE. J) GOTO 7 >*/
if (-data_1.icon1[ipr - 1] != *j) {
goto L7;
}
/*< GOTO 4 >*/
goto L4;
/*< 2 IF( IPR.NE. J) GOTO 3 >*/
L2:
if (ipr != *j) {
goto L3;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) {
goto L7;
}
/*< GOTO 5 >*/
goto L5;
/*< 3 IF( ICON2( IPR).NE. J) GOTO 7 >*/
L3:
if (data_1.icon2[ipr - 1] != *j) {
goto L7;
}
/*< 4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L4:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 7 >*/
if (xi < .999999) {
goto L7;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L7;
}
/*< 5 IND1=0 >*/
L5:
dataj_1.ind1 = 0;
/*< GOTO 8 >*/
goto L8;
/*< 6 IND1=1 >*/
L6:
dataj_1.ind1 = 1;
/*< GOTO 8 >*/
goto L8;
/*< 7 IND1=2 >*/
L7:
dataj_1.ind1 = 2;
/*< 8 IPR= ICON2( J) >*/
L8:
ipr = data_1.icon2[*j - 1];
/*< IF( IPR) 9,14,10 >*/
if (ipr < 0) {
goto L9;
} else if (ipr == 0) {
goto L14;
} else {
goto L10;
}
/*< 9 IPR=- IPR >*/
L9:
ipr = -ipr;
/*< IF(- ICON2( IPR).NE. J) GOTO 15 >*/
if (-data_1.icon2[ipr - 1] != *j) {
goto L15;
}
/*< GOTO 12 >*/
goto L12;
/*< 10 IF( IPR.NE. J) GOTO 11 >*/
L10:
if (ipr != *j) {
goto L11;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8) {
goto L15;
}
/*< GOTO 13 >*/
goto L13;
/*< 11 IF( ICON1( IPR).NE. J) GOTO 15 >*/
L11:
if (data_1.icon1[ipr - 1] != *j) {
goto L15;
}
/*< 12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L12:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 15 >*/
if (xi < .999999) {
goto L15;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L15;
}
/*< 13 IND2=0 >*/
L13:
dataj_1.ind2 = 0;
/*< GOTO 16 >*/
goto L16;
/*< 14 IND2=1 >*/
L14:
dataj_1.ind2 = 1;
/*< GOTO 16 >*/
goto L16;
/*< 15 IND2=2 >*/
L15:
dataj_1.ind2 = 2;
/* OBSERVATION LOOP */
/*< 16 CONTINUE >*/
L16:
/*< IPR=0 >*/
ipr = 0;
/*< DO 23 I= I1, I2 >*/
i__1 = *i2;
for (i = *i1; i <= i__1; ++i) {
/*< IPR= IPR+1 >*/
++ipr;
/*< IJ= I- J >*/
ij = i - *j;
/*< XI= X( I) >*/
xi = data_1.x[i - 1];
/*< YI= Y( I) >*/
yi = data_1.y[i - 1];
/*< ZI= Z( I) >*/
zi = data_1.z[i - 1];
/*< AI= BI( I) >*/
ai = data_1.bi[i - 1];
/*< CABI= CAB( I) >*/
cabi = cab[i - 1];
/*< SABI= SAB( I) >*/
sabi = sab[i - 1];
/*< SALPI= SALP( I) >*/
salpi = angl_1.salp[i - 1];
/*< CALL EFLD( XI, YI, ZI, AI, IJ) >*/
efld_(&xi, &yi, &zi, &ai, &ij);
/*< ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
z__3.r = cabi * dataj_1.exk.r, z__3.i = cabi * dataj_1.exk.i;
z__4.r = sabi * dataj_1.eyk.r, z__4.i = sabi * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezk.r, z__5.i = salpi * dataj_1.ezk.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etk.r = z__1.r, etk.i = z__1.i;
/*< ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
z__3.r = cabi * dataj_1.exs.r, z__3.i = cabi * dataj_1.exs.i;
z__4.r = sabi * dataj_1.eys.r, z__4.i = sabi * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezs.r, z__5.i = salpi * dataj_1.ezs.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ets.r = z__1.r, ets.i = z__1.i;
/* FILL MATRIX ELEMENTS. ELEMENT LOCATIONS DETERMINED BY CONNECTI
ON */
/* DATA. */
/*< ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI >*/
z__3.r = cabi * dataj_1.exc.r, z__3.i = cabi * dataj_1.exc.i;
z__4.r = sabi * dataj_1.eyc.r, z__4.i = sabi * dataj_1.eyc.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezc.r, z__5.i = salpi * dataj_1.ezc.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etc.r = z__1.r, etc.i = z__1.i;
/* NORMAL FILL */
/*< IF( ITRP.NE.0) GOTO 18 >*/
if (*itrp != 0) {
goto L18;
}
/*< DO 17 IJ=1, JSNO >*/
i__2 = segj_1.jsno;
for (ij = 1; ij <= i__2; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< >*/
/* L17: */
i__3 = ipr + jx * cm_dim1;
i__4 = ipr + jx * cm_dim1;
i__5 = ij - 1;
z__4.r = segj_1.ax[i__5] * etk.r, z__4.i = segj_1.ax[i__5] *
etk.i;
z__3.r = cm[i__4].r + z__4.r, z__3.i = cm[i__4].i + z__4.i;
i__6 = ij - 1;
z__5.r = segj_1.bx[i__6] * ets.r, z__5.i = segj_1.bx[i__6] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__7 = ij - 1;
z__6.r = segj_1.cx[i__7] * etc.r, z__6.i = segj_1.cx[i__7] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__3].r = z__1.r, cm[i__3].i = z__1.i;
}
/*< GOTO 23 >*/
goto L23;
/* TRANSPOSED FILL */
/*< 18 IF( ITRP.EQ.2) GOTO 20 >*/
L18:
if (*itrp == 2) {
goto L20;
}
/*< DO 19 IJ=1, JSNO >*/
i__3 = segj_1.jsno;
for (ij = 1; ij <= i__3; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< >*/
/* L19: */
i__4 = jx + ipr * cm_dim1;
i__5 = jx + ipr * cm_dim1;
i__6 = ij - 1;
z__4.r = segj_1.ax[i__6] * etk.r, z__4.i = segj_1.ax[i__6] *
etk.i;
z__3.r = cm[i__5].r + z__4.r, z__3.i = cm[i__5].i + z__4.i;
i__7 = ij - 1;
z__5.r = segj_1.bx[i__7] * ets.r, z__5.i = segj_1.bx[i__7] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__2 = ij - 1;
z__6.r = segj_1.cx[i__2] * etc.r, z__6.i = segj_1.cx[i__2] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__4].r = z__1.r, cm[i__4].i = z__1.i;
}
/* TRANS. FILL FOR C(WW) - TEST FOR ELEMENTS FOR D(WW)PRIME. (=CW
) */
/*< GOTO 23 >*/
goto L23;
/*< 20 DO 22 IJ=1, JSNO >*/
L20:
i__4 = segj_1.jsno;
for (ij = 1; ij <= i__4; ++ij) {
/*< JX= JCO( IJ) >*/
jx = segj_1.jco[ij - 1];
/*< IF( JX.GT. NR) GOTO 21 >*/
if (jx > *nr) {
goto L21;
}
/*< >*/
i__5 = jx + ipr * cm_dim1;
i__6 = jx + ipr * cm_dim1;
i__7 = ij - 1;
z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] *
etk.i;
z__3.r = cm[i__6].r + z__4.r, z__3.i = cm[i__6].i + z__4.i;
i__2 = ij - 1;
z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__3 = ij - 1;
z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cm[i__5].r = z__1.r, cm[i__5].i = z__1.i;
/*< GOTO 22 >*/
goto L22;
/*< 21 JX= JX- NR >*/
L21:
jx -= *nr;
/*< >*/
i__5 = jx + ipr * cw_dim1;
i__6 = jx + ipr * cw_dim1;
i__7 = ij - 1;
z__4.r = segj_1.ax[i__7] * etk.r, z__4.i = segj_1.ax[i__7] *
etk.i;
z__3.r = cw[i__6].r + z__4.r, z__3.i = cw[i__6].i + z__4.i;
i__2 = ij - 1;
z__5.r = segj_1.bx[i__2] * ets.r, z__5.i = segj_1.bx[i__2] *
ets.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
i__3 = ij - 1;
z__6.r = segj_1.cx[i__3] * etc.r, z__6.i = segj_1.cx[i__3] *
etc.i;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
cw[i__5].r = z__1.r, cw[i__5].i = z__1.i;
/*< 22 CONTINUE >*/
L22:
;
}
/*< 23 CONTINUE >*/
L23:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* cmww_ */
#undef sab
#undef cab
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE CONECT( IGND) >*/
/* Subroutine */ int conect_(ignd)
integer *ignd;
{
/* Initialized data */
static integer jmax = 30;
static doublereal smin = .001;
static integer nsmax = 50;
static integer npmax = 10;
/* Format strings */
static char fmt_54[] = "(/,3x,\002GROUND PLANE SPECIFIED.\002)";
static char fmt_55[] = "(/,3x,\002WHERE WIRE ENDS TOUCH GROUND, CURRENT \
WILL BE \002,\002INTERPOLATED TO IMAGE IN GROUND PLANE.\002,/)";
static char fmt_56[] = "(\002 GEOMETRY DATA ERROR-- SEGMENT\002,i5,\002 \
EXTENDS BELOW GRO\002,\002UND\002)";
static char fmt_57[] = "(\002 GEOMETRY DATA ERROR--SEGMENT\002,i5,\002 L\
IES IN GROUND \002,\002PLANE.\002)";
static char fmt_62[] = "(\002 ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.\
F. SEGMENTS\002,\002OR PATCHES EXCEEDS LIMIT OF\002,i5)";
static char fmt_58[] = "(/,3x,\002TOTAL SEGMENTS USED=\002,i5,5x,\002NO.\
SEG. IN \002,\002A SY\002,\002MMETRIC CELL=\002,i5,5x,\002SYMMETRY FLAG=\
\002,i3)";
static char fmt_61[] = "(3x,\002TOTAL PATCHES USED=\002,i5,6x,\002NO. PA\
TCHES IN A SYMMET\002,\002RIC CELL=\002,i5)";
static char fmt_59[] = "(\002 STRUCTURE HAS\002,i4,\002 FOLD ROTATIONAL \
SYMMETRY\002,/)";
static char fmt_60[] = "(\002 STRUCTURE HAS\002,i2,\002 PLANES OF SYMMET\
RY\002,/)";
static char fmt_50[] = "(//,9x,\002- MULTIPLE WIRE JUNCTIONS -\002,/,1x\
,\002JUNCTION\002,4x,\002SEGMENTS (- FOR END 1, + FOR END 2)\002)";
static char fmt_51[] = "(1x,i5,5x,20i5,/,(11x,20i5))";
static char fmt_52[] = "(2x,\002NONE\002)";
static char fmt_53[] = "(\002 CONNECT - SEGMENT CONNECTION ERROR FOR SEG\
MENT\002,i5)";
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2, d__3, d__4;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
double sqrt();
integer do_fio();
/* Local variables */
static integer iend, jend, iseg;
static doublereal slen;
static integer i, j, nsflg;
extern /* Subroutine */ int subph_();
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static integer ic;
static doublereal xa;
static integer ix;
static doublereal ya, za, xs, ys, zs, xi1, yi1, zi1, xi2, yi2, zi2, sep;
/* Fortran I/O blocks */
static cilist io___409 = { 0, 6, 0, fmt_54, 0 };
static cilist io___410 = { 0, 6, 0, fmt_55, 0 };
static cilist io___419 = { 0, 6, 0, fmt_56, 0 };
static cilist io___423 = { 0, 6, 0, fmt_56, 0 };
static cilist io___424 = { 0, 6, 0, fmt_57, 0 };
static cilist io___433 = { 0, 6, 0, fmt_62, 0 };
static cilist io___434 = { 0, 6, 0, fmt_58, 0 };
static cilist io___435 = { 0, 6, 0, fmt_61, 0 };
static cilist io___436 = { 0, 6, 0, fmt_59, 0 };
static cilist io___437 = { 0, 6, 0, fmt_60, 0 };
static cilist io___438 = { 0, 6, 0, fmt_50, 0 };
static cilist io___442 = { 0, 6, 0, fmt_62, 0 };
static cilist io___443 = { 0, 6, 0, fmt_51, 0 };
static cilist io___444 = { 0, 6, 0, fmt_52, 0 };
static cilist io___445 = { 0, 6, 0, fmt_53, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
*/
/* BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< DIMENSION X2(1), Y2(1), Z2(1) >*/
/*< EQUIVALENCE(X2,SI),(Y2,ALP),(Z2,BET) >*/
/*< DATA JMAX/30/, SMIN/1.D-3/, NSMAX/50/, NPMAX/10/ >*/
/*< NSCON=0 >*/
segj_1.nscon = 0;
/*< NPCON=0 >*/
segj_1.npcon = 0;
/*< IF( IGND.EQ.0) GOTO 3 >*/
if (*ignd == 0) {
goto L3;
}
/*< WRITE( 6,54) >*/
s_wsfe(&io___409);
e_wsfe();
/*< IF( IGND.GT.0) WRITE( 6,55) >*/
if (*ignd > 0) {
s_wsfe(&io___410);
e_wsfe();
}
/*< IF( IPSYM.NE.2) GOTO 1 >*/
if (data_1.ipsym != 2) {
goto L1;
}
/*< NP=2* NP >*/
data_1.np <<= 1;
/*< MP=2* MP >*/
data_1.mp <<= 1;
/*< 1 IF( IABS( IPSYM).LE.2) GOTO 2 >*/
L1:
if (abs(data_1.ipsym) <= 2) {
goto L2;
}
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< 2 IF( NP.GT. N) STOP >*/
L2:
if (data_1.np > data_1.n) {
s_stop("", 0L);
}
/*< IF( NP.EQ. N.AND. MP.EQ. M) IPSYM=0 >*/
if (data_1.np == data_1.n && data_1.mp == data_1.m) {
data_1.ipsym = 0;
}
/*< 3 IF( N.EQ.0) GOTO 26 >*/
L3:
if (data_1.n == 0) {
goto L26;
}
/*< DO 15 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< ICONX( I)=0 >*/
data_1.iconx[i - 1] = 0;
/*< XI1= X( I) >*/
xi1 = data_1.x[i - 1];
/*< YI1= Y( I) >*/
yi1 = data_1.y[i - 1];
/*< ZI1= Z( I) >*/
zi1 = data_1.z[i - 1];
/*< XI2= X2( I) >*/
xi2 = x2[i - 1];
/*< YI2= Y2( I) >*/
yi2 = y2[i - 1];
/*< ZI2= Z2( I) >*/
zi2 = z2[i - 1];
/* DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT. */
/*< SLEN= SQRT(( XI2- XI1)**2+( YI2- YI1)**2+( ZI2- ZI1)**2)* SMIN >*/
/* Computing 2nd power */
d__2 = xi2 - xi1;
/* Computing 2nd power */
d__3 = yi2 - yi1;
d__1 = d__2 * d__2 + d__3 * d__3;
/* Computing 2nd power */
d__4 = zi2 - zi1;
slen = sqrt(d__1 + d__4 * d__4) * smin;
/*< IF( IGND.LT.1) GOTO 5 >*/
if (*ignd < 1) {
goto L5;
}
/*< IF( ZI1.GT.- SLEN) GOTO 4 >*/
if (zi1 > -slen) {
goto L4;
}
/*< WRITE( 6,56) I >*/
s_wsfe(&io___419);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 4 IF( ZI1.GT. SLEN) GOTO 5 >*/
L4:
if (zi1 > slen) {
goto L5;
}
/*< ICON1( I)= I >*/
data_1.icon1[i - 1] = i;
/*< Z( I)=0. >*/
data_1.z[i - 1] = 0.;
/*< GOTO 9 >*/
goto L9;
/*< 5 IC= I >*/
L5:
ic = i;
/*< DO 7 J=2, N >*/
i__2 = data_1.n;
for (j = 2; j <= i__2; ++j) {
/*< IC= IC+1 >*/
++ic;
/*< IF( IC.GT. N) IC=1 >*/
if (ic > data_1.n) {
ic = 1;
}
/*< SEP= ABS( XI1- X( IC))+ ABS( YI1- Y( IC))+ ABS( ZI1- Z( IC)) >*/
d__4 = (d__1 = xi1 - data_1.x[ic - 1], abs(d__1)) + (d__2 = yi1 -
data_1.y[ic - 1], abs(d__2));
sep = d__4 + (d__3 = zi1 - data_1.z[ic - 1], abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 6 >*/
if (sep > slen) {
goto L6;
}
/*< ICON1( I)=- IC >*/
data_1.icon1[i - 1] = -ic;
/*< GOTO 8 >*/
goto L8;
/*< 6 SEP= ABS( XI1- X2( IC))+ ABS( YI1- Y2( IC))+ ABS( ZI1- Z2( IC)) >*/
L6:
d__4 = (d__1 = xi1 - x2[ic - 1], abs(d__1)) + (d__2 = yi1 - y2[ic
- 1], abs(d__2));
sep = d__4 + (d__3 = zi1 - z2[ic - 1], abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 7 >*/
if (sep > slen) {
goto L7;
}
/*< ICON1( I)= IC >*/
data_1.icon1[i - 1] = ic;
/*< GOTO 8 >*/
goto L8;
/*< 7 CONTINUE >*/
L7:
;
}
/*< IF( I.LT. N2.AND. ICON1( I).GT.10000) GOTO 8 >*/
if (i < data_1.n2 && data_1.icon1[i - 1] > 10000) {
goto L8;
}
/* DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT. */
/*< ICON1( I)=0 >*/
data_1.icon1[i - 1] = 0;
/*< 8 IF( IGND.LT.1) GOTO 12 >*/
L8:
if (*ignd < 1) {
goto L12;
}
/*< 9 IF( ZI2.GT.- SLEN) GOTO 10 >*/
L9:
if (zi2 > -slen) {
goto L10;
}
/*< WRITE( 6,56) I >*/
s_wsfe(&io___423);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 10 IF( ZI2.GT. SLEN) GOTO 12 >*/
L10:
if (zi2 > slen) {
goto L12;
}
/*< IF( ICON1( I).NE. I) GOTO 11 >*/
if (data_1.icon1[i - 1] != i) {
goto L11;
}
/*< WRITE( 6,57) I >*/
s_wsfe(&io___424);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 11 ICON2( I)= I >*/
L11:
data_1.icon2[i - 1] = i;
/*< Z2( I)=0. >*/
z2[i - 1] = 0.;
/*< GOTO 15 >*/
goto L15;
/*< 12 IC= I >*/
L12:
ic = i;
/*< DO 14 J=2, N >*/
i__2 = data_1.n;
for (j = 2; j <= i__2; ++j) {
/*< IC= IC+1 >*/
++ic;
/*< IF( IC.GT. N) IC=1 >*/
if (ic > data_1.n) {
ic = 1;
}
/*< SEP= ABS( XI2- X( IC))+ ABS( YI2- Y( IC))+ ABS( ZI2- Z( IC)) >*/
d__4 = (d__1 = xi2 - data_1.x[ic - 1], abs(d__1)) + (d__2 = yi2 -
data_1.y[ic - 1], abs(d__2));
sep = d__4 + (d__3 = zi2 - data_1.z[ic - 1], abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 13 >*/
if (sep > slen) {
goto L13;
}
/*< ICON2( I)= IC >*/
data_1.icon2[i - 1] = ic;
/*< GOTO 15 >*/
goto L15;
/*< 13 SEP= ABS( XI2- X2( IC))+ ABS( YI2- Y2( IC))+ ABS( ZI2- Z2( IC)) >*/
L13:
d__4 = (d__1 = xi2 - x2[ic - 1], abs(d__1)) + (d__2 = yi2 - y2[ic
- 1], abs(d__2));
sep = d__4 + (d__3 = zi2 - z2[ic - 1], abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 14 >*/
if (sep > slen) {
goto L14;
}
/*< ICON2( I)=- IC >*/
data_1.icon2[i - 1] = -ic;
/*< GOTO 15 >*/
goto L15;
/*< 14 CONTINUE >*/
L14:
;
}
/*< IF( I.LT. N2.AND. ICON2( I).GT.10000) GOTO 15 >*/
if (i < data_1.n2 && data_1.icon2[i - 1] > 10000) {
goto L15;
}
/*< ICON2( I)=0 >*/
data_1.icon2[i - 1] = 0;
/*< 15 CONTINUE >*/
L15:
;
}
/* FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES */
/*< IF( M.EQ.0) GOTO 26 >*/
if (data_1.m == 0) {
goto L26;
}
/*< IX= LD+1- M1 >*/
ix = data_1.ld + 1 - data_1.m1;
/*< I= M2 >*/
i = data_1.m2;
/*< 16 IF( I.GT. M) GOTO 20 >*/
L16:
if (i > data_1.m) {
goto L20;
}
/*< IX= IX-1 >*/
--ix;
/*< XS= X( IX) >*/
xs = data_1.x[ix - 1];
/*< YS= Y( IX) >*/
ys = data_1.y[ix - 1];
/*< ZS= Z( IX) >*/
zs = data_1.z[ix - 1];
/*< DO 18 ISEG=1, N >*/
i__1 = data_1.n;
for (iseg = 1; iseg <= i__1; ++iseg) {
/*< XI1= X( ISEG) >*/
xi1 = data_1.x[iseg - 1];
/*< YI1= Y( ISEG) >*/
yi1 = data_1.y[iseg - 1];
/*< ZI1= Z( ISEG) >*/
zi1 = data_1.z[iseg - 1];
/*< XI2= X2( ISEG) >*/
xi2 = x2[iseg - 1];
/*< YI2= Y2( ISEG) >*/
yi2 = y2[iseg - 1];
/*< ZI2= Z2( ISEG) >*/
zi2 = z2[iseg - 1];
/* FOR FIRST END OF SEGMENT */
/*< SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN >*/
d__4 = (d__1 = xi2 - xi1, abs(d__1)) + (d__2 = yi2 - yi1, abs(d__2));
slen = (d__4 + (d__3 = zi2 - zi1, abs(d__3))) * smin;
/*< SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS) >*/
d__4 = (d__1 = xi1 - xs, abs(d__1)) + (d__2 = yi1 - ys, abs(d__2));
sep = d__4 + (d__3 = zi1 - zs, abs(d__3));
/* CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.
*/
/*< IF( SEP.GT. SLEN) GOTO 17 >*/
if (sep > slen) {
goto L17;
}
/*< ICON1( ISEG)=10000+ I >*/
data_1.icon1[iseg - 1] = i + 10000;
/*< IC=0 >*/
ic = 0;
/*< >*/
subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
xs, &ys, &zs);
/*< GOTO 19 >*/
goto L19;
/*< 17 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS) >*/
L17:
d__4 = (d__1 = xi2 - xs, abs(d__1)) + (d__2 = yi2 - ys, abs(d__2));
sep = d__4 + (d__3 = zi2 - zs, abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 18 >*/
if (sep > slen) {
goto L18;
}
/*< ICON2( ISEG)=10000+ I >*/
data_1.icon2[iseg - 1] = i + 10000;
/*< IC=0 >*/
ic = 0;
/*< >*/
subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
xs, &ys, &zs);
/*< GOTO 19 >*/
goto L19;
/*< 18 CONTINUE >*/
L18:
;
}
/*< 19 I= I+1 >*/
L19:
++i;
/* REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES. */
/*< GOTO 16 >*/
goto L16;
/*< 20 IF( M1.EQ.0.OR. N2.GT. N) GOTO 26 >*/
L20:
if (data_1.m1 == 0 || data_1.n2 > data_1.n) {
goto L26;
}
/*< IX= LD+1 >*/
ix = data_1.ld + 1;
/*< I=1 >*/
i = 1;
/*< 21 IF( I.GT. M1) GOTO 25 >*/
L21:
if (i > data_1.m1) {
goto L25;
}
/*< IX= IX-1 >*/
--ix;
/*< XS= X( IX) >*/
xs = data_1.x[ix - 1];
/*< YS= Y( IX) >*/
ys = data_1.y[ix - 1];
/*< ZS= Z( IX) >*/
zs = data_1.z[ix - 1];
/*< DO 23 ISEG= N2, N >*/
i__1 = data_1.n;
for (iseg = data_1.n2; iseg <= i__1; ++iseg) {
/*< XI1= X( ISEG) >*/
xi1 = data_1.x[iseg - 1];
/*< YI1= Y( ISEG) >*/
yi1 = data_1.y[iseg - 1];
/*< ZI1= Z( ISEG) >*/
zi1 = data_1.z[iseg - 1];
/*< XI2= X2( ISEG) >*/
xi2 = x2[iseg - 1];
/*< YI2= Y2( ISEG) >*/
yi2 = y2[iseg - 1];
/*< ZI2= Z2( ISEG) >*/
zi2 = z2[iseg - 1];
/*< SLEN=( ABS( XI2- XI1)+ ABS( YI2- YI1)+ ABS( ZI2- ZI1))* SMIN >*/
d__4 = (d__1 = xi2 - xi1, abs(d__1)) + (d__2 = yi2 - yi1, abs(d__2));
slen = (d__4 + (d__3 = zi2 - zi1, abs(d__3))) * smin;
/*< SEP= ABS( XI1- XS)+ ABS( YI1- YS)+ ABS( ZI1- ZS) >*/
d__4 = (d__1 = xi1 - xs, abs(d__1)) + (d__2 = yi1 - ys, abs(d__2));
sep = d__4 + (d__3 = zi1 - zs, abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 22 >*/
if (sep > slen) {
goto L22;
}
/*< ICON1( ISEG)=10001+ M >*/
data_1.icon1[iseg - 1] = data_1.m + 10001;
/*< IC=1 >*/
ic = 1;
/*< NPCON= NPCON+1 >*/
++segj_1.npcon;
/*< IPCON( NPCON)= I >*/
segj_1.ipcon[segj_1.npcon - 1] = i;
/*< >*/
subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
xs, &ys, &zs);
/*< GOTO 24 >*/
goto L24;
/*< 22 SEP= ABS( XI2- XS)+ ABS( YI2- YS)+ ABS( ZI2- ZS) >*/
L22:
d__4 = (d__1 = xi2 - xs, abs(d__1)) + (d__2 = yi2 - ys, abs(d__2));
sep = d__4 + (d__3 = zi2 - zs, abs(d__3));
/*< IF( SEP.GT. SLEN) GOTO 23 >*/
if (sep > slen) {
goto L23;
}
/*< ICON2( ISEG)=10001+ M >*/
data_1.icon2[iseg - 1] = data_1.m + 10001;
/*< IC=1 >*/
ic = 1;
/*< NPCON= NPCON+1 >*/
++segj_1.npcon;
/*< IPCON( NPCON)= I >*/
segj_1.ipcon[segj_1.npcon - 1] = i;
/*< >*/
subph_(&i, &ic, &xi1, &yi1, &zi1, &xi2, &yi2, &zi2, &xa, &ya, &za, &
xs, &ys, &zs);
/*< GOTO 24 >*/
goto L24;
/*< 23 CONTINUE >*/
L23:
;
}
/*< 24 I= I+1 >*/
L24:
++i;
/*< GOTO 21 >*/
goto L21;
/*< 25 IF( NPCON.LE. NPMAX) GOTO 26 >*/
L25:
if (segj_1.npcon <= npmax) {
goto L26;
}
/*< WRITE( 6,62) NPMAX >*/
s_wsfe(&io___433);
do_fio(&c__1, (char *)&npmax, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 26 WRITE( 6,58) N, NP, IPSYM >*/
L26:
s_wsfe(&io___434);
do_fio(&c__1, (char *)&data_1.n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( M.GT.0) WRITE( 6,61) M, MP >*/
if (data_1.m > 0) {
s_wsfe(&io___435);
do_fio(&c__1, (char *)&data_1.m, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
e_wsfe();
}
/*< ISEG=( N+ M)/( NP+ MP) >*/
iseg = (data_1.n + data_1.m) / (data_1.np + data_1.mp);
/*< IF( ISEG.EQ.1) GOTO 30 >*/
if (iseg == 1) {
goto L30;
}
/*< IF( IPSYM) 28,27,29 >*/
if (data_1.ipsym < 0) {
goto L28;
} else if (data_1.ipsym == 0) {
goto L27;
} else {
goto L29;
}
/*< 27 STOP >*/
L27:
s_stop("", 0L);
/*< 28 WRITE( 6,59) ISEG >*/
L28:
s_wsfe(&io___436);
do_fio(&c__1, (char *)&iseg, (ftnlen)sizeof(integer));
e_wsfe();
/*< GOTO 30 >*/
goto L30;
/*< 29 IC= ISEG/2 >*/
L29:
ic = iseg / 2;
/*< IF( ISEG.EQ.8) IC=3 >*/
if (iseg == 8) {
ic = 3;
}
/*< WRITE( 6,60) IC >*/
s_wsfe(&io___437);
do_fio(&c__1, (char *)&ic, (ftnlen)sizeof(integer));
e_wsfe();
/*< 30 IF( N.EQ.0) GOTO 48 >*/
L30:
if (data_1.n == 0) {
goto L48;
}
/*< WRITE( 6,50) >*/
s_wsfe(&io___438);
e_wsfe();
/* ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE. PRINT JUNCTIONS */
/* OF 3 OR MORE SEG. ALSO FIND OLD SEG. CONNECTING TO NEW SEG. */
/*< ISEG=0 >*/
iseg = 0;
/*< DO 44 J=1, N >*/
i__1 = data_1.n;
for (j = 1; j <= i__1; ++j) {
/*< IEND=-1 >*/
iend = -1;
/*< JEND=-1 >*/
jend = -1;
/*< IX= ICON1( J) >*/
ix = data_1.icon1[j - 1];
/*< IC=1 >*/
ic = 1;
/*< JCO(1)=- J >*/
segj_1.jco[0] = -j;
/*< XA= X( J) >*/
xa = data_1.x[j - 1];
/*< YA= Y( J) >*/
ya = data_1.y[j - 1];
/*< ZA= Z( J) >*/
za = data_1.z[j - 1];
/*< 31 IF( IX.EQ.0) GOTO 43 >*/
L31:
if (ix == 0) {
goto L43;
}
/*< IF( IX.EQ. J) GOTO 43 >*/
if (ix == j) {
goto L43;
}
/*< IF( IX.GT.10000) GOTO 43 >*/
if (ix > 10000) {
goto L43;
}
/*< NSFLG=0 >*/
nsflg = 0;
/*< 32 IF( IX) 33,49,34 >*/
L32:
if (ix < 0) {
goto L33;
} else if (ix == 0) {
goto L49;
} else {
goto L34;
}
/*< 33 IX=- IX >*/
L33:
ix = -ix;
/*< GOTO 35 >*/
goto L35;
/*< 34 JEND=- JEND >*/
L34:
jend = -jend;
/*< 35 IF( IX.EQ. J) GOTO 37 >*/
L35:
if (ix == j) {
goto L37;
}
/*< IF( IX.LT. J) GOTO 43 >*/
if (ix < j) {
goto L43;
}
/*< IC= IC+1 >*/
++ic;
/*< IF( IC.GT. JMAX) GOTO 49 >*/
if (ic > jmax) {
goto L49;
}
/*< JCO( IC)= IX* JEND >*/
segj_1.jco[ic - 1] = ix * jend;
/*< IF( IX.GT. N1) NSFLG=1 >*/
if (ix > data_1.n1) {
nsflg = 1;
}
/*< IF( JEND.EQ.1) GOTO 36 >*/
if (jend == 1) {
goto L36;
}
/*< XA= XA+ X( IX) >*/
xa += data_1.x[ix - 1];
/*< YA= YA+ Y( IX) >*/
ya += data_1.y[ix - 1];
/*< ZA= ZA+ Z( IX) >*/
za += data_1.z[ix - 1];
/*< IX= ICON1( IX) >*/
ix = data_1.icon1[ix - 1];
/*< GOTO 32 >*/
goto L32;
/*< 36 XA= XA+ X2( IX) >*/
L36:
xa += x2[ix - 1];
/*< YA= YA+ Y2( IX) >*/
ya += y2[ix - 1];
/*< ZA= ZA+ Z2( IX) >*/
za += z2[ix - 1];
/*< IX= ICON2( IX) >*/
ix = data_1.icon2[ix - 1];
/*< GOTO 32 >*/
goto L32;
/*< 37 SEP= IC >*/
L37:
sep = (doublereal) ic;
/*< XA= XA/ SEP >*/
xa /= sep;
/*< YA= YA/ SEP >*/
ya /= sep;
/*< ZA= ZA/ SEP >*/
za /= sep;
/*< DO 39 I=1, IC >*/
i__2 = ic;
for (i = 1; i <= i__2; ++i) {
/*< IX= JCO( I) >*/
ix = segj_1.jco[i - 1];
/*< IF( IX.GT.0) GOTO 38 >*/
if (ix > 0) {
goto L38;
}
/*< IX=- IX >*/
ix = -ix;
/*< X( IX)= XA >*/
data_1.x[ix - 1] = xa;
/*< Y( IX)= YA >*/
data_1.y[ix - 1] = ya;
/*< Z( IX)= ZA >*/
data_1.z[ix - 1] = za;
/*< GOTO 39 >*/
goto L39;
/*< 38 X2( IX)= XA >*/
L38:
x2[ix - 1] = xa;
/*< Y2( IX)= YA >*/
y2[ix - 1] = ya;
/*< Z2( IX)= ZA >*/
z2[ix - 1] = za;
/*< 39 CONTINUE >*/
L39:
;
}
/*< IF( N1.EQ.0) GOTO 42 >*/
if (data_1.n1 == 0) {
goto L42;
}
/*< IF( NSFLG.EQ.0) GOTO 42 >*/
if (nsflg == 0) {
goto L42;
}
/*< DO 41 I=1, IC >*/
i__2 = ic;
for (i = 1; i <= i__2; ++i) {
/*< IX= IABS( JCO( I)) >*/
ix = (i__3 = segj_1.jco[i - 1], abs(i__3));
/*< IF( IX.GT. N1) GOTO 41 >*/
if (ix > data_1.n1) {
goto L41;
}
/*< IF( ICONX( IX).NE.0) GOTO 41 >*/
if (data_1.iconx[ix - 1] != 0) {
goto L41;
}
/*< NSCON= NSCON+1 >*/
++segj_1.nscon;
/*< IF( NSCON.LE. NSMAX) GOTO 40 >*/
if (segj_1.nscon <= nsmax) {
goto L40;
}
/*< WRITE( 6,62) NSMAX >*/
s_wsfe(&io___442);
do_fio(&c__1, (char *)&nsmax, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 40 ISCON( NSCON)= IX >*/
L40:
segj_1.iscon[segj_1.nscon - 1] = ix;
/*< ICONX( IX)= NSCON >*/
data_1.iconx[ix - 1] = segj_1.nscon;
/*< 41 CONTINUE >*/
L41:
;
}
/*< 42 IF( IC.LT.3) GOTO 43 >*/
L42:
if (ic < 3) {
goto L43;
}
/*< ISEG= ISEG+1 >*/
++iseg;
/*< WRITE( 6,51) ISEG,( JCO( I), I=1, IC) >*/
s_wsfe(&io___443);
do_fio(&c__1, (char *)&iseg, (ftnlen)sizeof(integer));
i__2 = ic;
for (i = 1; i <= i__2; ++i) {
do_fio(&c__1, (char *)&segj_1.jco[i - 1], (ftnlen)sizeof(integer))
;
}
e_wsfe();
/*< 43 IF( IEND.EQ.1) GOTO 44 >*/
L43:
if (iend == 1) {
goto L44;
}
/*< IEND=1 >*/
iend = 1;
/*< JEND=1 >*/
jend = 1;
/*< IX= ICON2( J) >*/
ix = data_1.icon2[j - 1];
/*< IC=1 >*/
ic = 1;
/*< JCO(1)= J >*/
segj_1.jco[0] = j;
/*< XA= X2( J) >*/
xa = x2[j - 1];
/*< YA= Y2( J) >*/
ya = y2[j - 1];
/*< ZA= Z2( J) >*/
za = z2[j - 1];
/*< GOTO 31 >*/
goto L31;
/*< 44 CONTINUE >*/
L44:
;
}
/*< IF( ISEG.EQ.0) WRITE( 6,52) >*/
if (iseg == 0) {
s_wsfe(&io___444);
e_wsfe();
}
/* FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES */
/*< IF( N1.EQ.0.OR. M1.EQ. M) GOTO 48 >*/
if (data_1.n1 == 0 || data_1.m1 == data_1.m) {
goto L48;
}
/*< DO 47 J=1, N1 >*/
i__1 = data_1.n1;
for (j = 1; j <= i__1; ++j) {
/*< IX= ICON1( J) >*/
ix = data_1.icon1[j - 1];
/*< IF( IX.LT.10000) GOTO 45 >*/
if (ix < 10000) {
goto L45;
}
/*< IX= IX-10000 >*/
ix += -10000;
/*< IF( IX.GT. M1) GOTO 46 >*/
if (ix > data_1.m1) {
goto L46;
}
/*< 45 IX= ICON2( J) >*/
L45:
ix = data_1.icon2[j - 1];
/*< IF( IX.LT.10000) GOTO 47 >*/
if (ix < 10000) {
goto L47;
}
/*< IX= IX-10000 >*/
ix += -10000;
/*< IF( IX.LT. M2) GOTO 47 >*/
if (ix < data_1.m2) {
goto L47;
}
/*< 46 IF( ICONX( J).NE.0) GOTO 47 >*/
L46:
if (data_1.iconx[j - 1] != 0) {
goto L47;
}
/*< NSCON= NSCON+1 >*/
++segj_1.nscon;
/*< ISCON( NSCON)= J >*/
segj_1.iscon[segj_1.nscon - 1] = j;
/*< ICONX( J)= NSCON >*/
data_1.iconx[j - 1] = segj_1.nscon;
/*< 47 CONTINUE >*/
L47:
;
}
/*< 48 CONTINUE >*/
L48:
/*< RETURN >*/
return 0;
/*< 49 WRITE( 6,53) IX >*/
L49:
s_wsfe(&io___445);
do_fio(&c__1, (char *)&ix, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< >*/
/*< 51 FORMAT(1X,I5,5X,20I5,/,(11X,20I5)) >*/
/*< 52 FORMAT(2X,'NONE') >*/
/*< 53 FORMAT(' CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
/*< 54 FORMAT(/,3X,'GROUND PLANE SPECIFIED.') >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 59 FORMAT(' STRUCTURE HAS',I4,' FOLD ROTATIONAL SYMMETRY',/) >*/
/*< 60 FORMAT(' STRUCTURE HAS',I2,' PLANES OF SYMMETRY',/) >*/
/*< >*/
/*< >*/
/*< END >*/
} /* conect_ */
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE COUPLE( CUR, WLAM) >*/
/* Subroutine */ int couple_(cur, wlam)
doublecomplex *cur;
doublereal *wlam;
{
/* Format strings */
static char fmt_6[] = "(///,36x,\002- - - ISOLATION DATA - - -\002,//,\
6x,\002- - COUPLIN\002,\002G BETWEEN - -\002,8x,\002MAXIMUM\002,15x,\002- - \
- FOR MAXIMUM COUPLING - \002,\002- -\002,/,12x,\002SEG.\002,14x,\002SEG.\
\002,3x,\002COUPLING\002,4x,\002LOAD IMPEDANCE \002,\002(2ND SEG.)\002,7x\
,\002INPUT IMPEDANCE\002,/,2x,\002TAG/SEG.\002,3x,\002NO.\002,4x,\002TAG/'SE\
G.\002,3x,\002NO.\002,6x,\002(DB)\002,8x,\002REAL\002,9x,\002IMAG.\002,9x\
,\002REAL\002,9x,\002IMAG.\002)";
static char fmt_7[] = "(2(1x,i4,1x,i4,1x,i5,2x),f9.3,2x,1p,2(2x,e12.5,1x\
,e12.5))";
static char fmt_8[] = "(2(1x,i4,1x,i4,1x,i5,2x),\002**ERROR** COUPLING I\
S NOT BETWE\002,\002EN 0 AND 1. (=\002,1p,e12.5,\002)\002)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
void z_div();
integer s_wsfe(), e_wsfe();
double z_abs(), sqrt();
void d_cnjg();
integer do_fio();
/* Local variables */
static doublereal gmax, c;
static integer i, j, k, j1, l1, j2;
static doublecomplex y11, y12, y22, yl, zl;
extern integer isegno_();
extern doublereal db10_();
static doublereal dbc;
static doublecomplex rho, yin, zin;
static integer isg1, isg2, npm1, its1, itt1, itt2, its2;
/* Fortran I/O blocks */
static cilist io___451 = { 0, 6, 0, fmt_6, 0 };
static cilist io___471 = { 0, 6, 0, fmt_7, 0 };
static cilist io___472 = { 0, 6, 0, fmt_8, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* COUPLE COMPUTES THE MAXIMUM COUPLING BETWEEN PAIRS OF SEGMENTS. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< DIMENSION CUR(1) >*/
/*< IF( NSANT.NE.1.OR. NVQD.NE.0) RETURN >*/
/* Parameter adjustments */
--cur;
/* Function Body */
if (vsorc_1.nsant != 1 || vsorc_1.nvqd != 0) {
return 0;
}
/*< J= ISEGNO( NCTAG( ICOUP+1), NCSEG( ICOUP+1)) >*/
j = isegno_(&yparm_1.nctag[yparm_1.icoup], &yparm_1.ncseg[yparm_1.icoup]);
/*< IF( J.NE. ISANT(1)) RETURN >*/
if (j != vsorc_1.isant[0]) {
return 0;
}
/*< ICOUP= ICOUP+1 >*/
++yparm_1.icoup;
/*< ZIN= VSANT(1) >*/
zin.r = vsorc_1.vsant[0].r, zin.i = vsorc_1.vsant[0].i;
/*< Y11A( ICOUP)= CUR( J)* WLAM/ ZIN >*/
i__1 = yparm_1.icoup - 1;
i__2 = j;
z__2.r = *wlam * cur[i__2].r, z__2.i = *wlam * cur[i__2].i;
z_div(&z__1, &z__2, &zin);
yparm_1.y11a[i__1].r = z__1.r, yparm_1.y11a[i__1].i = z__1.i;
/*< L1=( ICOUP-1)*( NCOUP-1) >*/
l1 = (yparm_1.icoup - 1) * (yparm_1.ncoup - 1);
/*< DO 1 I=1, NCOUP >*/
i__1 = yparm_1.ncoup;
for (i = 1; i <= i__1; ++i) {
/*< IF( I.EQ. ICOUP) GOTO 1 >*/
if (i == yparm_1.icoup) {
goto L1;
}
/*< K= ISEGNO( NCTAG( I), NCSEG( I)) >*/
k = isegno_(&yparm_1.nctag[i - 1], &yparm_1.ncseg[i - 1]);
/*< L1= L1+1 >*/
++l1;
/*< Y12A( L1)= CUR( K)* WLAM/ ZIN >*/
i__2 = l1 - 1;
i__3 = k;
z__2.r = *wlam * cur[i__3].r, z__2.i = *wlam * cur[i__3].i;
z_div(&z__1, &z__2, &zin);
yparm_1.y12a[i__2].r = z__1.r, yparm_1.y12a[i__2].i = z__1.i;
/*< 1 CONTINUE >*/
L1:
;
}
/*< IF( ICOUP.LT. NCOUP) RETURN >*/
if (yparm_1.icoup < yparm_1.ncoup) {
return 0;
}
/*< WRITE( 6,6) >*/
s_wsfe(&io___451);
e_wsfe();
/*< NPM1= NCOUP-1 >*/
npm1 = yparm_1.ncoup - 1;
/*< DO 5 I=1, NPM1 >*/
i__1 = npm1;
for (i = 1; i <= i__1; ++i) {
/*< ITT1= NCTAG( I) >*/
itt1 = yparm_1.nctag[i - 1];
/*< ITS1= NCSEG( I) >*/
its1 = yparm_1.ncseg[i - 1];
/*< ISG1= ISEGNO( ITT1, ITS1) >*/
isg1 = isegno_(&itt1, &its1);
/*< L1= I+1 >*/
l1 = i + 1;
/*< DO 5 J= L1, NCOUP >*/
i__2 = yparm_1.ncoup;
for (j = l1; j <= i__2; ++j) {
/*< ITT2= NCTAG( J) >*/
itt2 = yparm_1.nctag[j - 1];
/*< ITS2= NCSEG( J) >*/
its2 = yparm_1.ncseg[j - 1];
/*< ISG2= ISEGNO( ITT2, ITS2) >*/
isg2 = isegno_(&itt2, &its2);
/*< J1= J+( I-1)* NPM1-1 >*/
j1 = j + (i - 1) * npm1 - 1;
/*< J2= I+( J-1)* NPM1 >*/
j2 = i + (j - 1) * npm1;
/*< Y11= Y11A( I) >*/
i__3 = i - 1;
y11.r = yparm_1.y11a[i__3].r, y11.i = yparm_1.y11a[i__3].i;
/*< Y22= Y11A( J) >*/
i__3 = j - 1;
y22.r = yparm_1.y11a[i__3].r, y22.i = yparm_1.y11a[i__3].i;
/*< Y12=.5*( Y12A( J1)+ Y12A( J2)) >*/
i__3 = j1 - 1;
i__4 = j2 - 1;
z__2.r = yparm_1.y12a[i__3].r + yparm_1.y12a[i__4].r, z__2.i =
yparm_1.y12a[i__3].i + yparm_1.y12a[i__4].i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
y12.r = z__1.r, y12.i = z__1.i;
/*< YIN= Y12* Y12 >*/
z__1.r = y12.r * y12.r - y12.i * y12.i, z__1.i = y12.r * y12.i +
y12.i * y12.r;
yin.r = z__1.r, yin.i = z__1.i;
/*< DBC= ABS( YIN) >*/
dbc = z_abs(&yin);
/*< C= DBC/(2.* REAL( Y11)* REAL( Y22)- REAL( YIN)) >*/
d__1 = y11.r * 2.;
c = dbc / (d__1 * y22.r - yin.r);
/*< IF( C.LT.0..OR. C.GT.1.) GOTO 4 >*/
if (c < 0. || c > 1.) {
goto L4;
}
/*< IF( C.LT..01) GOTO 2 >*/
if (c < .01) {
goto L2;
}
/*< GMAX=(1.- SQRT(1.- C* C))/ C >*/
gmax = (1. - sqrt(1. - c * c)) / c;
/*< GOTO 3 >*/
goto L3;
/*< 2 GMAX=.5*( C+.25* C* C* C) >*/
L2:
d__2 = c * .25;
d__1 = d__2 * c;
gmax = (c + d__1 * c) * .5;
/*< 3 RHO= GMAX* CONJG( YIN)/ DBC >*/
L3:
d_cnjg(&z__3, &yin);
z__2.r = gmax * z__3.r, z__2.i = gmax * z__3.i;
z__1.r = z__2.r / dbc, z__1.i = z__2.i / dbc;
rho.r = z__1.r, rho.i = z__1.i;
/*< YL=((1.- RHO)/(1.+ RHO)+1.)* REAL( Y22)- Y22 >*/
z__5.r = 1. - rho.r, z__5.i = -rho.i;
z__6.r = rho.r + 1., z__6.i = rho.i;
z_div(&z__4, &z__5, &z__6);
z__3.r = z__4.r + 1., z__3.i = z__4.i;
d__1 = y22.r;
z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
z__1.r = z__2.r - y22.r, z__1.i = z__2.i - y22.i;
yl.r = z__1.r, yl.i = z__1.i;
/*< ZL=1./ YL >*/
z_div(&z__1, &c_b48, &yl);
zl.r = z__1.r, zl.i = z__1.i;
/*< YIN= Y11- YIN/( Y22+ YL) >*/
z__3.r = y22.r + yl.r, z__3.i = y22.i + yl.i;
z_div(&z__2, &yin, &z__3);
z__1.r = y11.r - z__2.r, z__1.i = y11.i - z__2.i;
yin.r = z__1.r, yin.i = z__1.i;
/*< ZIN=1./ YIN >*/
z_div(&z__1, &c_b48, &yin);
zin.r = z__1.r, zin.i = z__1.i;
/*< DBC= DB10( GMAX) >*/
dbc = db10_(&gmax);
/*< WRITE( 6,7) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, DBC, ZL, ZIN >*/
s_wsfe(&io___471);
do_fio(&c__1, (char *)&itt1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&its1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isg1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itt2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&its2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isg2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&dbc, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&zl, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&zin, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 5 >*/
goto L5;
/*< 4 WRITE( 6,8) ITT1, ITS1, ISG1, ITT2, ITS2, ISG2, C >*/
L4:
s_wsfe(&io___472);
do_fio(&c__1, (char *)&itt1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&its1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isg1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itt2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&its2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isg2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&c, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 5 CONTINUE >*/
L5:
;
}
}
/*< RETURN >*/
return 0;
/*< >*/
/*< 7 FORMAT(2(1X,I4,1X,I4,1X,I5,2X),F9.3,2X,1P,2(2X,E12.5,1X,E12.5)) >*/
/*< >*/
/*< END >*/
} /* couple_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE DATAGN >*/
/* Subroutine */ int datagn_()
{
/* Initialized data */
static char atst[2*13+1] = "GWGXGRGSGEGMSPSMGFGASCGCGH";
static struct {
char e_1[8];
integer e_2;
} equiv_555 = { {' ', ' ', ' ', ' ', 'X', ' ', ' ', ' '}, 0 };
#define ifx ((integer *)&equiv_555)
static struct {
char e_1[8];
integer e_2;
} equiv_556 = { {' ', ' ', ' ', ' ', 'Y', ' ', ' ', ' '}, 0 };
#define ify ((integer *)&equiv_556)
static struct {
char e_1[8];
integer e_2;
} equiv_557 = { {' ', ' ', ' ', ' ', 'Z', ' ', ' ', ' '}, 0 };
#define ifz ((integer *)&equiv_557)
static doublereal ta = .01745329252;
static doublereal td = 57.29577951;
static struct {
char e_1[16];
integer e_2;
} equiv_558 = { {'P', ' ', ' ', ' ', 'R', ' ', ' ', ' ', 'T', ' ',
' ', ' ', 'Q', ' ', ' ', ' '}, 0 };
#define ipt ((integer *)&equiv_558)
/* Format strings */
static char fmt_40[] = "(////,33x,\002- - - STRUCTURE SPECIFICATION - \
- -\002,//,37x,\002COORDINATES MUST BE INPUT IN\002,/,37x,\002METERS OR BE S\
CALED TO METERS\002,/,37x,\002BEFORE STRUCTURE INPUT IS ENDED\002,//)";
static char fmt_41[] = "(2x,\002WIRE\002,79x,\002NO. OF\002,4x,\002FIRS\
T\002,2x,\002LAST\002,5x,\002TAG\002,/,2x,\002NO.\002,8x,\002X1\002,9x,\002Y1\
\002,9x,\002Z1\002,10x,\002X2\002,9x,\002Y2\002,9x,\002Z2\002,6x,\002RADIU\
S\002,3x,\002SEG.\002,5x,\002SEG.\002,3x,\002SEG.\002,5x,\002NO.\002)";
static char fmt_43[] = "(1x,i5,3f11.5,1x,4f11.5,2x,i5,4x,i5,1x,i5,3x,i5)";
static char fmt_48[] = "(\002 GEOMETRY DATA CARD ERROR\002)";
static char fmt_61[] = "(9x,\002ABOVE WIRE IS TAPERED. SEG. LENGTH RATI\
O =\002,f9.5,/,33x,\002RADIUS FROM\002,f9.5,\002 TO\002,f9.5)";
static char fmt_38[] = "(1x,i5,2x,\002ARC RADIUS =\002,f9.5,2x,\002FRO\
M\002,f8.3,\002 TO\002,f8.3,\002 DEGREES\002,11x,f11.5,2x,i5,4x,i5,1x,i5,3x,\
i5)";
static char fmt_124[] = "(5x,\002HELIX STRUCTURE- AXIAL SPACING BETWEE\
N TURNS =\002,f8.3,\002 TOTAL AXIAL LENGTH =\002,f8.3/1x,i5,2x,\002RADIUS OF\
HELIX =\002,4(2x,f8.3),7x,f11.5,i8,4x,i5,1x,i5,3x,i5)";
static char fmt_51[] = "(1x,i5,a1,f10.5,2f11.5,1x,3f11.5)";
static char fmt_39[] = "(6x,3f11.5,1x,3f11.5)";
static char fmt_59[] = "(1x,i5,a1,f10.5,2f11.5,1x,3f11.5,5x,\002SURFAC\
E -\002,i4,\002 BY\002,i3,\002 PATCHES\002)";
static char fmt_60[] = "(\002 PATCH DATA ERROR\002)";
static char fmt_44[] = "(6x,\002STRUCTURE REFLECTED ALONG THE AXES\002,3\
(1x,a1),\002. TA\002,\002GS INCREMENTED BY\002,i5)";
static char fmt_45[] = "(6x,\002STRUCTURE ROTATED ABOUT Z-AXIS\002,i3\
,\002 TIMES. LABELS\002,\002 INCREMENTED BY\002,i5)";
static char fmt_46[] = "(6x,\002STRUCTURE SCALED BY FACTOR\002,f10.5)";
static char fmt_47[] = "(6x,\002THE STRUCTURE HAS BEEN MOVED, MOVE DATA \
CARD IS -/6X\002,i3,i5,7f10.5)";
static char fmt_52[] = "(\002 ERROR - GF MUST BE FIRST GEOMETRY DATA C\
ARD\002)";
static char fmt_53[] = "(////33x,\002- - - - SEGMENTATION DATA - - - \
-\002,//,40x,\002COO\002,\002RDINATES IN METERS\002,//,25x,\002I+ AND I- IND\
ICATE THE SEGMENTS BEFORE AND AFTER I\002,//)";
static char fmt_54[] = "(2x,\002SEG.\002,3x,\002COORDINATES OF SEG. CENT\
ER\002,5x,\002SEG.\002,5x,\002ORIENTATION ANGLES\002,4x,\002WIRE\002,4x,\002\
CONNECTION DATA\002,3x,\002TAG\002,/,2x,\002NO.\002,7x,\002X\002,9x,\002Y\
\002,9x,\002Z\002,7x,\002LENGTH\002,5x,\002ALPHA\002,5x,\002BETA\002,6x,\002\
RADIUS\002,4x,\002I-\002,3x,\002I\002,4x,\002I+\002,4x,\002NO.\002)";
static char fmt_55[] = "(1x,i5,4f10.5,1x,3f10.5,1x,3i5,2x,i5)";
static char fmt_56[] = "(\002 SEGMENT DATA ERROR\002)";
static char fmt_57[] = "(////,44x,\002- - - SURFACE PATCH DATA - - -\002\
,//,49x,\002COORD\002,\002INATES IN METERS\002,//,1x,\002PATCH\002,5x,\002CO\
ORD. OF PATCH CENTER\002,7x,\002UNIT NORMAL VECTOR\002,6x,\002PATCH\002,12x\
,\002COMPONENTS OF UNIT TANGENT V'ECTORS\002,/,2x,\002NO.\002,6x,\002X\002,9\
x,\002Y\002,9x,\002Z\002,9x,\002X\002,7x,\002Y\002,7x,\002Z\002,7x,\002ARE\
A\002,7x,\002X1\002,6x,\002Y1\002,6x,\002Z1\002,7x,\002X2\002,6x,\002Y2\002,\
6x,\002Z2\002)";
static char fmt_58[] = "(1x,i4,3f10.5,1x,3f8.4,f10.5,1x,3f8.4,1x,3f8.4)";
static char fmt_49[] = "(1x,a2,i3,i5,7f10.5)";
static char fmt_50[] = "(\002 NUMBER OF WIRE SEGMENTS AND SURFACE PATCHE\
S EXCEEDS DI\002,\002MENSION LIMIT.\002)";
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
integer s_cmp(), s_wsfe(), e_wsfe(), do_fio();
/* Subroutine */ int s_stop();
double pow_dd(), sqrt(), asin();
integer s_wsle(), do_lio(), e_wsle();
/* Local variables */
extern /* Subroutine */ int gfil_();
static integer iphd, isct;
extern /* Subroutine */ int wire_(), move_();
extern doublereal atgn2_();
static integer i, j;
extern /* Subroutine */ int reflc_(), patch_(), helix_();
static integer ipsav, nwire, mpsav, npsav, i1, i2;
static doublereal dummy;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal x4, y4, z4, x3, y3, z3;
static char gm[2];
extern /* Subroutine */ int readgm_();
static integer ns, ix, iy, iz;
extern /* Subroutine */ int conect_();
static doublereal xs1;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
static doublereal xw1, yw1, zw1;
#define cab ((doublereal *)&data_1 + 3000)
static doublereal xw2, yw2, zw2, ys1, zs1, xs2, ys2, zs2;
#define sab ((doublereal *)&data_1 + 3600)
static doublereal rad;
extern /* Subroutine */ int arc_();
static integer itg;
/* Fortran I/O blocks */
static cilist io___504 = { 0, 6, 0, fmt_40, 0 };
static cilist io___505 = { 0, 6, 0, fmt_41, 0 };
static cilist io___508 = { 0, 6, 0, fmt_43, 0 };
static cilist io___515 = { 0, 6, 0, fmt_48, 0 };
static cilist io___516 = { 0, 6, 0, fmt_61, 0 };
static cilist io___517 = { 0, 6, 0, fmt_38, 0 };
static cilist io___518 = { 0, 6, 0, fmt_124, 0 };
static cilist io___519 = { 0, 6, 0, fmt_51, 0 };
static cilist io___529 = { 0, 6, 0, fmt_51, 0 };
static cilist io___530 = { 0, 6, 0, fmt_39, 0 };
static cilist io___531 = { 0, 6, 0, fmt_59, 0 };
static cilist io___532 = { 0, 6, 0, fmt_39, 0 };
static cilist io___533 = { 0, 6, 0, fmt_60, 0 };
static cilist io___535 = { 0, 6, 0, fmt_44, 0 };
static cilist io___536 = { 0, 6, 0, fmt_45, 0 };
static cilist io___538 = { 0, 6, 0, fmt_46, 0 };
static cilist io___539 = { 0, 6, 0, fmt_47, 0 };
static cilist io___540 = { 0, 6, 0, fmt_52, 0 };
static cilist io___544 = { 0, 6, 0, fmt_53, 0 };
static cilist io___545 = { 0, 6, 0, fmt_54, 0 };
static cilist io___546 = { 0, 6, 0, fmt_55, 0 };
static cilist io___547 = { 0, 8, 0, 0, 0 };
static cilist io___548 = { 0, 6, 0, fmt_56, 0 };
static cilist io___549 = { 0, 6, 0, fmt_57, 0 };
static cilist io___551 = { 0, 6, 0, fmt_58, 0 };
static cilist io___552 = { 0, 6, 0, fmt_48, 0 };
static cilist io___553 = { 0, 6, 0, fmt_49, 0 };
static cilist io___554 = { 0, 6, 0, fmt_50, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* DATAGN IS THE MAIN ROUTINE FOR INPUT OF GEOMETRY DATA. */
/* *** */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/* *** */
/*< CHARACTER *2 GM, ATST >*/
/* *** */
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/* *** */
/*< COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
/*< >*/
/* *** */
/*< >*/
/* *** */
/*< >*/
/* DATA ATST/2HGW,2HGX,2HGR,2HGS,2HGE,2HGM,2HSP,2HSM,2HGF,2HGA, */
/* &2HSC,2HGC,2HGH/ */
/*< DATA IFX/1H ,1HX/, IFY/1H ,1HY/, IFZ/1H ,1HZ/ >*/
/*< >*/
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< NWIRE=0 >*/
nwire = 0;
/*< N=0 >*/
data_1.n = 0;
/*< NP=0 >*/
data_1.np = 0;
/*< M=0 >*/
data_1.m = 0;
/*< MP=0 >*/
data_1.mp = 0;
/*< N1=0 >*/
data_1.n1 = 0;
/*< N2=1 >*/
data_1.n2 = 1;
/*< M1=0 >*/
data_1.m1 = 0;
/*< M2=1 >*/
data_1.m2 = 1;
/*< ISCT=0 >*/
isct = 0;
/* READ GEOMETRY DATA CARD AND BRANCH TO SECTION FOR OPERATION */
/* REQUESTED */
/* *** */
/* 1 READ (5,42) GM,ITG,NS,XW1,YW1,ZW1,XW2,YW2,ZW2,RAD */
/*< IPHD=0 >*/
iphd = 0;
/* *** */
/*< 1 CALL READGM( GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD) >*/
L1:
readgm_(gm, &itg, &ns, &xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, 2L);
/*< IF( N+ M.GT. LD) GOTO 37 >*/
if (data_1.n + data_1.m > data_1.ld) {
goto L37;
}
/*< IF( GM.EQ. ATST(9)) GOTO 27 >*/
if (s_cmp(gm, atst + 16, 2L, 2L) == 0) {
goto L27;
}
/*< IF( IPHD.EQ.1) GOTO 2 >*/
if (iphd == 1) {
goto L2;
}
/*< WRITE( 6,40) >*/
s_wsfe(&io___504);
e_wsfe();
/*< WRITE( 6,41) >*/
s_wsfe(&io___505);
e_wsfe();
/*< IPHD=1 >*/
iphd = 1;
/*< 2 IF( GM.EQ. ATST(11)) GOTO 10 >*/
L2:
if (s_cmp(gm, atst + 20, 2L, 2L) == 0) {
goto L10;
}
/*< ISCT=0 >*/
isct = 0;
/*< IF( GM.EQ. ATST(1)) GOTO 3 >*/
if (s_cmp(gm, atst, 2L, 2L) == 0) {
goto L3;
}
/*< IF( GM.EQ. ATST(2)) GOTO 18 >*/
if (s_cmp(gm, atst + 2, 2L, 2L) == 0) {
goto L18;
}
/*< IF( GM.EQ. ATST(3)) GOTO 19 >*/
if (s_cmp(gm, atst + 4, 2L, 2L) == 0) {
goto L19;
}
/*< IF( GM.EQ. ATST(4)) GOTO 21 >*/
if (s_cmp(gm, atst + 6, 2L, 2L) == 0) {
goto L21;
}
/*< IF( GM.EQ. ATST(7)) GOTO 9 >*/
if (s_cmp(gm, atst + 12, 2L, 2L) == 0) {
goto L9;
}
/*< IF( GM.EQ. ATST(8)) GOTO 13 >*/
if (s_cmp(gm, atst + 14, 2L, 2L) == 0) {
goto L13;
}
/*< IF( GM.EQ. ATST(5)) GOTO 29 >*/
if (s_cmp(gm, atst + 8, 2L, 2L) == 0) {
goto L29;
}
/*< IF( GM.EQ. ATST(6)) GOTO 26 >*/
if (s_cmp(gm, atst + 10, 2L, 2L) == 0) {
goto L26;
}
/* *** */
/*< IF( GM.EQ. ATST(10)) GOTO 8 >*/
if (s_cmp(gm, atst + 18, 2L, 2L) == 0) {
goto L8;
}
/* *** */
/*< IF( GM.EQ. ATST(13)) GOTO 123 >*/
if (s_cmp(gm, atst + 24, 2L, 2L) == 0) {
goto L123;
}
/* GENERATE SEGMENT DATA FOR STRAIGHT WIRE. */
/*< GOTO 36 >*/
goto L36;
/*< 3 NWIRE= NWIRE+1 >*/
L3:
++nwire;
/*< I1= N+1 >*/
i1 = data_1.n + 1;
/*< I2= N+ NS >*/
i2 = data_1.n + ns;
/*< >*/
s_wsfe(&io___508);
do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( RAD.EQ.0) GOTO 4 >*/
if (rad == 0.) {
goto L4;
}
/*< XS1=1. >*/
xs1 = 1.;
/*< YS1=1. >*/
ys1 = 1.;
/* *** */
/*< GOTO 7 >*/
goto L7;
/* 4 READ (5,42) GM,IX,IY,XS1,YS1,ZS1 */
/* *** */
/*< >*/
L4:
readgm_(gm, &ix, &iy, &xs1, &ys1, &zs1, &dummy, &dummy, &dummy, &dummy,
2L);
/*< IF( GM.EQ. ATST(12)) GOTO 6 >*/
if (s_cmp(gm, atst + 22, 2L, 2L) == 0) {
goto L6;
}
/*< 5 WRITE( 6,48) >*/
L5:
s_wsfe(&io___515);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 6 WRITE( 6,61) XS1, YS1, ZS1 >*/
L6:
s_wsfe(&io___516);
do_fio(&c__1, (char *)&xs1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ys1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zs1, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( YS1.EQ.0.OR. ZS1.EQ.0) GOTO 5 >*/
if (ys1 == 0. || zs1 == 0.) {
goto L5;
}
/*< RAD= YS1 >*/
rad = ys1;
/*< YS1=( ZS1/ YS1)**(1./( NS-1.)) >*/
d__1 = zs1 / ys1;
d__2 = 1. / (ns - 1.);
ys1 = pow_dd(&d__1, &d__2);
/*< 7 CALL WIRE( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, XS1, YS1, NS, ITG) >*/
L7:
wire_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, &xs1, &ys1, &ns, &itg);
/* GENERATE SEGMENT DATA FOR WIRE ARC */
/*< GOTO 1 >*/
goto L1;
/*< 8 NWIRE= NWIRE+1 >*/
L8:
++nwire;
/*< I1= N+1 >*/
i1 = data_1.n + 1;
/*< I2= N+ NS >*/
i2 = data_1.n + ns;
/*< WRITE( 6,38) NWIRE, XW1, YW1, ZW1, XW2, NS, I1, I2, ITG >*/
s_wsfe(&io___517);
do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
e_wsfe();
/*< CALL ARC( ITG, NS, XW1, YW1, ZW1, XW2) >*/
arc_(&itg, &ns, &xw1, &yw1, &zw1, &xw2);
/* *** */
/* GENERATE HELIX */
/*< GOTO 1 >*/
goto L1;
/*< 123 NWIRE= NWIRE+1 >*/
L123:
++nwire;
/*< I1= N+1 >*/
i1 = data_1.n + 1;
/*< I2= N+ NS >*/
i2 = data_1.n + ns;
/*< >*/
s_wsfe(&io___518);
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&nwire, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
e_wsfe();
/*< CALL HELIX( XW1, YW1, ZW1, XW2, YW2, ZW2, RAD, NS, ITG) >*/
helix_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &rad, &ns, &itg);
/*< GOTO 1 >*/
goto L1;
/* *** */
/* GENERATE SINGLE NEW PATCH */
/*< >*/
/*< 9 I1= M+1 >*/
L9:
i1 = data_1.m + 1;
/*< NS= NS+1 >*/
++ns;
/*< IF( ITG.NE.0) GOTO 17 >*/
if (itg != 0) {
goto L17;
}
/*< WRITE( 6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2 >*/
s_wsfe(&io___519);
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ipt[ns - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( NS.EQ.2.OR. NS.EQ.4) ISCT=1 >*/
if (ns == 2 || ns == 4) {
isct = 1;
}
/*< IF( NS.GT.1) GOTO 14 >*/
if (ns > 1) {
goto L14;
}
/*< XW2= XW2* TA >*/
xw2 *= ta;
/*< YW2= YW2* TA >*/
yw2 *= ta;
/*< GOTO 16 >*/
goto L16;
/*< 10 IF( ISCT.EQ.0) GOTO 17 >*/
L10:
if (isct == 0) {
goto L17;
}
/*< I1= M+1 >*/
i1 = data_1.m + 1;
/*< NS= NS+1 >*/
++ns;
/*< IF( ITG.NE.0) GOTO 17 >*/
if (itg != 0) {
goto L17;
}
/*< IF( NS.NE.2.AND. NS.NE.4) GOTO 17 >*/
if (ns != 2 && ns != 4) {
goto L17;
}
/*< XS1= X4 >*/
xs1 = x4;
/*< YS1= Y4 >*/
ys1 = y4;
/*< ZS1= Z4 >*/
zs1 = z4;
/*< XS2= X3 >*/
xs2 = x3;
/*< YS2= Y3 >*/
ys2 = y3;
/*< ZS2= Z3 >*/
zs2 = z3;
/*< X3= XW1 >*/
x3 = xw1;
/*< Y3= YW1 >*/
y3 = yw1;
/*< Z3= ZW1 >*/
z3 = zw1;
/*< IF( NS.NE.4) GOTO 11 >*/
if (ns != 4) {
goto L11;
}
/*< X4= XW2 >*/
x4 = xw2;
/*< Y4= YW2 >*/
y4 = yw2;
/*< Z4= ZW2 >*/
z4 = zw2;
/*< 11 XW1= XS1 >*/
L11:
xw1 = xs1;
/*< YW1= YS1 >*/
yw1 = ys1;
/*< ZW1= ZS1 >*/
zw1 = zs1;
/*< XW2= XS2 >*/
xw2 = xs2;
/*< YW2= YS2 >*/
yw2 = ys2;
/*< ZW2= ZS2 >*/
zw2 = zs2;
/*< IF( NS.EQ.4) GOTO 12 >*/
if (ns == 4) {
goto L12;
}
/*< X4= XW1+ X3- XW2 >*/
x4 = xw1 + x3 - xw2;
/*< Y4= YW1+ Y3- YW2 >*/
y4 = yw1 + y3 - yw2;
/*< Z4= ZW1+ Z3- ZW2 >*/
z4 = zw1 + z3 - zw2;
/*< 12 WRITE( 6,51) I1, IPT( NS), XW1, YW1, ZW1, XW2, YW2, ZW2 >*/
L12:
s_wsfe(&io___529);
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ipt[ns - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< WRITE( 6,39) X3, Y3, Z3, X4, Y4, Z4 >*/
s_wsfe(&io___530);
do_fio(&c__1, (char *)&x3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&y3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&z3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&x4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&y4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&z4, (ftnlen)sizeof(doublereal));
e_wsfe();
/* GENERATE MULTIPLE-PATCH SURFACE */
/*< GOTO 16 >*/
goto L16;
/*< 13 I1= M+1 >*/
L13:
i1 = data_1.m + 1;
/*< WRITE( 6,59) I1, IPT(2), XW1, YW1, ZW1, XW2, YW2, ZW2, ITG, NS >*/
s_wsfe(&io___531);
do_fio(&c__1, (char *)&i1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ipt[1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
e_wsfe();
/* *** */
/*< IF( ITG.LT.1.OR. NS.LT.1) GOTO 17 >*/
if (itg < 1 || ns < 1) {
goto L17;
}
/* 14 READ (5,42) GM,IX,IY,X3,Y3,Z3,X4,Y4,Z4 */
/* *** */
/*< 14 CALL READGM( GM, IX, IY, X3, Y3, Z3, X4, Y4, Z4, DUMMY) >*/
L14:
readgm_(gm, &ix, &iy, &x3, &y3, &z3, &x4, &y4, &z4, &dummy, 2L);
/*< IF( NS.NE.2.AND. ITG.LT.1) GOTO 15 >*/
if (ns != 2 && itg < 1) {
goto L15;
}
/*< X4= XW1+ X3- XW2 >*/
x4 = xw1 + x3 - xw2;
/*< Y4= YW1+ Y3- YW2 >*/
y4 = yw1 + y3 - yw2;
/*< Z4= ZW1+ Z3- ZW2 >*/
z4 = zw1 + z3 - zw2;
/*< 15 WRITE( 6,39) X3, Y3, Z3, X4, Y4, Z4 >*/
L15:
s_wsfe(&io___532);
do_fio(&c__1, (char *)&x3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&y3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&z3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&x4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&y4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&z4, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( GM.NE. ATST(11)) GOTO 17 >*/
if (s_cmp(gm, atst + 20, 2L, 2L) != 0) {
goto L17;
}
/*< >*/
L16:
patch_(&itg, &ns, &xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &x3, &y3, &z3, &x4,
&y4, &z4);
/*< GOTO 1 >*/
goto L1;
/*< 17 WRITE( 6,60) >*/
L17:
s_wsfe(&io___533);
e_wsfe();
/* REFLECT STRUCTURE ALONG X,Y, OR Z AXES OR ROTATE TO FORM CYLINDER.
*/
/*< STOP >*/
s_stop("", 0L);
/*< 18 IY= NS/10 >*/
L18:
iy = ns / 10;
/*< IZ= NS- IY*10 >*/
iz = ns - iy * 10;
/*< IX= IY/10 >*/
ix = iy / 10;
/*< IY= IY- IX*10 >*/
iy -= ix * 10;
/*< IF( IX.NE.0) IX=1 >*/
if (ix != 0) {
ix = 1;
}
/*< IF( IY.NE.0) IY=1 >*/
if (iy != 0) {
iy = 1;
}
/*< IF( IZ.NE.0) IZ=1 >*/
if (iz != 0) {
iz = 1;
}
/*< WRITE( 6,44) IFX( IX+1), IFY( IY+1), IFZ( IZ+1), ITG >*/
s_wsfe(&io___535);
do_fio(&c__1, (char *)&ifx[ix], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ify[iy], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ifz[iz], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
e_wsfe();
/*< GOTO 20 >*/
goto L20;
/*< 19 WRITE( 6,45) NS, ITG >*/
L19:
s_wsfe(&io___536);
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
e_wsfe();
/*< IX=-1 >*/
ix = -1;
/*< 20 CALL REFLC( IX, IY, IZ, ITG, NS) >*/
L20:
reflc_(&ix, &iy, &iz, &itg, &ns);
/* SCALE STRUCTURE DIMENSIONS BY FACTOR XW1. */
/*< GOTO 1 >*/
goto L1;
/*< 21 IF( N.LT. N2) GOTO 23 >*/
L21:
if (data_1.n < data_1.n2) {
goto L23;
}
/*< DO 22 I= N2, N >*/
i__1 = data_1.n;
for (i = data_1.n2; i <= i__1; ++i) {
/*< X( I)= X( I)* XW1 >*/
data_1.x[i - 1] *= xw1;
/*< Y( I)= Y( I)* XW1 >*/
data_1.y[i - 1] *= xw1;
/*< Z( I)= Z( I)* XW1 >*/
data_1.z[i - 1] *= xw1;
/*< X2( I)= X2( I)* XW1 >*/
x2[i - 1] *= xw1;
/*< Y2( I)= Y2( I)* XW1 >*/
y2[i - 1] *= xw1;
/*< Z2( I)= Z2( I)* XW1 >*/
z2[i - 1] *= xw1;
/*< 22 BI( I)= BI( I)* XW1 >*/
/* L22: */
data_1.bi[i - 1] *= xw1;
}
/*< 23 IF( M.LT. M2) GOTO 25 >*/
L23:
if (data_1.m < data_1.m2) {
goto L25;
}
/*< YW1= XW1* XW1 >*/
yw1 = xw1 * xw1;
/*< IX= LD+1- M >*/
ix = data_1.ld + 1 - data_1.m;
/*< IY= LD- M1 >*/
iy = data_1.ld - data_1.m1;
/*< DO 24 I= IX, IY >*/
i__1 = iy;
for (i = ix; i <= i__1; ++i) {
/*< X( I)= X( I)* XW1 >*/
data_1.x[i - 1] *= xw1;
/*< Y( I)= Y( I)* XW1 >*/
data_1.y[i - 1] *= xw1;
/*< Z( I)= Z( I)* XW1 >*/
data_1.z[i - 1] *= xw1;
/*< 24 BI( I)= BI( I)* YW1 >*/
/* L24: */
data_1.bi[i - 1] *= yw1;
}
/*< 25 WRITE( 6,46) XW1 >*/
L25:
s_wsfe(&io___538);
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
e_wsfe();
/* MOVE STRUCTURE OR REPRODUCE ORIGINAL STRUCTURE IN NEW POSITIONS. */
/*< GOTO 1 >*/
goto L1;
/*< 26 WRITE( 6,47) ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD >*/
L26:
s_wsfe(&io___539);
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< XW1= XW1* TA >*/
xw1 *= ta;
/*< YW1= YW1* TA >*/
yw1 *= ta;
/*< ZW1= ZW1* TA >*/
zw1 *= ta;
/*< CALL MOVE( XW1, YW1, ZW1, XW2, YW2, ZW2, INT( RAD+.5), NS, ITG) >*/
i__1 = (integer) (rad + .5);
move_(&xw1, &yw1, &zw1, &xw2, &yw2, &zw2, &i__1, &ns, &itg);
/* READ NUMERICAL GREEN'S FUNCTION TAPE */
/*< GOTO 1 >*/
goto L1;
/*< 27 IF( N+ M.EQ.0) GOTO 28 >*/
L27:
if (data_1.n + data_1.m == 0) {
goto L28;
}
/*< WRITE( 6,52) >*/
s_wsfe(&io___540);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 28 CALL GFIL( ITG) >*/
L28:
gfil_(&itg);
/*< NPSAV= NP >*/
npsav = data_1.np;
/*< MPSAV= MP >*/
mpsav = data_1.mp;
/*< IPSAV= IPSYM >*/
ipsav = data_1.ipsym;
/* TERMINATE STRUCTURE GEOMETRY INPUT. */
/* *** */
/*< GOTO 1 >*/
goto L1;
/*< 29 IF( NS.EQ.0) GOTO 290 >*/
L29:
if (ns == 0) {
goto L290;
}
/*< IPLP1=1 >*/
plot_1.iplp1 = 1;
/*< IPLP2=1 >*/
plot_1.iplp2 = 1;
/* *** */
/*< 290 IX= N1+ M1 >*/
L290:
ix = data_1.n1 + data_1.m1;
/*< IF( IX.EQ.0) GOTO 30 >*/
if (ix == 0) {
goto L30;
}
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< 30 CALL CONECT( ITG) >*/
L30:
conect_(&itg);
/*< IF( IX.EQ.0) GOTO 31 >*/
if (ix == 0) {
goto L31;
}
/*< NP= NPSAV >*/
data_1.np = npsav;
/*< MP= MPSAV >*/
data_1.mp = mpsav;
/*< IPSYM= IPSAV >*/
data_1.ipsym = ipsav;
/*< 31 IF( N+ M.GT. LD) GOTO 37 >*/
L31:
if (data_1.n + data_1.m > data_1.ld) {
goto L37;
}
/*< IF( N.EQ.0) GOTO 33 >*/
if (data_1.n == 0) {
goto L33;
}
/*< WRITE( 6,53) >*/
s_wsfe(&io___544);
e_wsfe();
/*< WRITE( 6,54) >*/
s_wsfe(&io___545);
e_wsfe();
/*< DO 32 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< XW1= X2( I)- X( I) >*/
xw1 = x2[i - 1] - data_1.x[i - 1];
/*< YW1= Y2( I)- Y( I) >*/
yw1 = y2[i - 1] - data_1.y[i - 1];
/*< ZW1= Z2( I)- Z( I) >*/
zw1 = z2[i - 1] - data_1.z[i - 1];
/*< X( I)=( X( I)+ X2( I))*.5 >*/
data_1.x[i - 1] = (data_1.x[i - 1] + x2[i - 1]) * .5;
/*< Y( I)=( Y( I)+ Y2( I))*.5 >*/
data_1.y[i - 1] = (data_1.y[i - 1] + y2[i - 1]) * .5;
/*< Z( I)=( Z( I)+ Z2( I))*.5 >*/
data_1.z[i - 1] = (data_1.z[i - 1] + z2[i - 1]) * .5;
/*< XW2= XW1* XW1+ YW1* YW1+ ZW1* ZW1 >*/
d__1 = xw1 * xw1 + yw1 * yw1;
xw2 = d__1 + zw1 * zw1;
/*< YW2= SQRT( XW2) >*/
yw2 = sqrt(xw2);
/*< YW2=( XW2/ YW2+ YW2)*.5 >*/
yw2 = (xw2 / yw2 + yw2) * .5;
/*< SI( I)= YW2 >*/
data_1.si[i - 1] = yw2;
/*< CAB( I)= XW1/ YW2 >*/
cab[i - 1] = xw1 / yw2;
/*< SAB( I)= YW1/ YW2 >*/
sab[i - 1] = yw1 / yw2;
/*< XW2= ZW1/ YW2 >*/
xw2 = zw1 / yw2;
/*< IF( XW2.GT.1.) XW2=1. >*/
if (xw2 > 1.) {
xw2 = 1.;
}
/*< IF( XW2.LT.-1.) XW2=-1. >*/
if (xw2 < -1.) {
xw2 = -1.;
}
/*< SALP( I)= XW2 >*/
angl_1.salp[i - 1] = xw2;
/*< XW2= ASIN( XW2)* TD >*/
xw2 = asin(xw2) * td;
/*< YW2= ATGN2( YW1, XW1)* TD >*/
yw2 = atgn2_(&yw1, &xw1) * td;
/* *** */
/*< >*/
s_wsfe(&io___546);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( IPLP1.NE.1) GOTO 320 >*/
if (plot_1.iplp1 != 1) {
goto L320;
}
/*< >*/
s_wsle(&io___547);
do_lio(&c__5, &c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_lio(&c__5, &c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(
doublereal));
do_lio(&c__3, &c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(
integer));
do_lio(&c__3, &c__1, (char *)&i, (ftnlen)sizeof(integer));
do_lio(&c__3, &c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(
integer));
e_wsle();
/* *** */
/*< 320 CONTINUE >*/
L320:
/*< IF( SI( I).GT.1.D-20.AND. BI( I).GT.0.) GOTO 32 >*/
if (data_1.si[i - 1] > 1e-20 && data_1.bi[i - 1] > 0.) {
goto L32;
}
/*< WRITE( 6,56) >*/
s_wsfe(&io___548);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 32 CONTINUE >*/
L32:
;
}
/*< 33 IF( M.EQ.0) GOTO 35 >*/
L33:
if (data_1.m == 0) {
goto L35;
}
/*< WRITE( 6,57) >*/
s_wsfe(&io___549);
e_wsfe();
/*< J= LD+1 >*/
j = data_1.ld + 1;
/*< DO 34 I=1, M >*/
i__1 = data_1.m;
for (i = 1; i <= i__1; ++i) {
/*< J= J-1 >*/
--j;
/*< XW1=( T1Y( J)* T2Z( J)- T1Z( J)* T2Y( J))* SALP( J) >*/
xw1 = (t1y[j - 1] * t2z[j - 1] - t1z[j - 1] * t2y[j - 1]) *
angl_1.salp[j - 1];
/*< YW1=( T1Z( J)* T2X( J)- T1X( J)* T2Z( J))* SALP( J) >*/
yw1 = (t1z[j - 1] * t2x[j - 1] - t1x[j - 1] * t2z[j - 1]) *
angl_1.salp[j - 1];
/*< ZW1=( T1X( J)* T2Y( J)- T1Y( J)* T2X( J))* SALP( J) >*/
zw1 = (t1x[j - 1] * t2y[j - 1] - t1y[j - 1] * t2x[j - 1]) *
angl_1.salp[j - 1];
/*< >*/
s_wsfe(&io___551);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.y[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.z[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.bi[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t1x[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t1y[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t1z[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t2x[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t2y[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&t2z[j - 1], (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 34 CONTINUE >*/
/* L34: */
}
/*< 35 RETURN >*/
L35:
return 0;
/*< 36 WRITE( 6,48) >*/
L36:
s_wsfe(&io___552);
e_wsfe();
/*< WRITE( 6,49) GM, ITG, NS, XW1, YW1, ZW1, XW2, YW2, ZW2, RAD >*/
s_wsfe(&io___553);
do_fio(&c__1, gm, 2L);
do_fio(&c__1, (char *)&itg, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ns, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&xw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&xw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zw2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&rad, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 37 WRITE( 6,50) >*/
L37:
s_wsfe(&io___554);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< >*/
/*< 39 FORMAT(6X,3F11.5,1X,3F11.5) >*/
/*< >*/
/*< >*/
/*< 42 FORMAT(A2, I3, I5, 7F10.5) >*/
/* L42: */
/*< 43 FORMAT(1X,I5,3F11.5,1X,4F11.5,2X,I5,4X,I5,1X,I5,3X,I5) >*/
/*< >*/
/*< >*/
/*< 46 FORMAT(6X,'STRUCTURE SCALED BY FACTOR',F10.5) >*/
/*< >*/
/*< 48 FORMAT(' GEOMETRY DATA CARD ERROR') >*/
/*< 49 FORMAT(1X,A2,I3,I5,7F10.5) >*/
/*< >*/
/*< 51 FORMAT(1X,I5,A1,F10.5,2F11.5,1X,3F11.5) >*/
/*< 52 FORMAT(' ERROR - GF MUST BE FIRST GEOMETRY DATA CARD') >*/
/*< >*/
/*< >*/
/*< 55 FORMAT(1X,I5,4F10.5,1X,3F10.5,1X,3I5,2X,I5) >*/
/*< 56 FORMAT(' SEGMENT DATA ERROR') >*/
/*< >*/
/*< 58 FORMAT(1X,I4,3F10.5,1X,3F8.4,F10.5,1X,3F8.4,1X,3F8.4) >*/
/*< >*/
/*< 60 FORMAT(' PATCH DATA ERROR') >*/
/*< >*/
/*< END >*/
} /* datagn_ */
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef z2
#undef y2
#undef x2
#undef ipt
#undef ifz
#undef ify
#undef ifx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< FUNCTION DB10( X) >*/
doublereal db10_0_(n__, x)
int n__;
doublereal *x;
{
/* System generated locals */
doublereal ret_val;
/* Builtin functions */
double d_lg10();
/* Local variables */
static doublereal f;
/* *** */
/* FUNCTION DB-- RETURNS DB FOR MAGNITUDE (FIELD) OR MAG**2 (POWER) I
*/
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< F=10. >*/
switch(n__) {
case 1: goto L_db20;
}
f = 10.;
/*< GOTO 1 >*/
goto L1;
/*< ENTRY DB20 (x) >*/
L_db20:
/*< F=20. >*/
f = 20.;
/*< 1 IF( X.LT.1.D-20) GOTO 2 >*/
L1:
if (*x < 1e-20) {
goto L2;
}
/*< DB10= F* LOG10( X) >*/
ret_val = f * d_lg10(x);
/*< RETURN >*/
return ret_val;
/*< 2 DB10=-999.99 >*/
L2:
ret_val = -999.99;
/*< RETURN >*/
return ret_val;
/*< END >*/
} /* db10_ */
doublereal db10_(x)
doublereal *x;
{
return db10_0_(0, x);
}
doublereal db20_(x)
doublereal *x;
{
return db10_0_(1, x);
}
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE EFLD( XI, YI, ZI, AI, IJ) >*/
/* Subroutine */ int efld_(xi, yi, zi, ai, ij)
doublereal *xi, *yi, *zi, *ai;
integer *ij;
{
/* Initialized data */
static doublereal eta = 376.73;
static doublereal pi = 3.141592654;
static doublereal tp = 6.283185308;
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
static doublecomplex equiv_8[9];
/* Builtin functions */
double sqrt(), cos(), sin(), log();
void z_div(), z_sqrt(), d_cnjg();
/* Local variables */
#define egnd (equiv_8)
static doublereal shaf;
extern /* Subroutine */ int eksc_();
static doublereal rmag, dmin_;
static doublecomplex terc, refs, tezc, terk, ters, tezk;
static doublereal rhox, rhoy, rhoz;
static doublecomplex tezs;
static doublereal r;
extern /* Subroutine */ int sflds_(), ekscx_();
static doublecomplex refps;
static doublereal salpr, xspec, yspec, xymag;
static doublecomplex zscrn, zrsin, zratx;
static integer ip;
static doublereal rh, zp, px, py, rhospc, cth, rfl, xij, yij;
static doublecomplex epx, epy;
#define txc (equiv_8 + 6)
#define tyc (equiv_8 + 7)
#define tzc (equiv_8 + 8)
static integer ijx;
static doublereal zij;
#define txk (equiv_8)
#define tyk (equiv_8 + 1)
#define tzk (equiv_8 + 2)
#define txs (equiv_8 + 3)
#define tys (equiv_8 + 4)
#define tzs (equiv_8 + 5)
extern /* Subroutine */ int rom2_();
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* COMPUTE NEAR E FIELDS OF A SEGMENT WITH SINE, COSINE, AND */
/* CONSTANT CURRENTS. GROUND EFFECT INCLUDED. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR >*/
/*< DIMENSION EGND(9) >*/
/*< >*/
/*< DATA ETA/376.73/, PI/3.141592654D+0/, TP/6.283185308D+0/ >*/
/*< XIJ= XI- XJ >*/
xij = *xi - dataj_1.xj;
/*< YIJ= YI- YJ >*/
yij = *yi - dataj_1.yj;
/*< IJX= IJ >*/
ijx = *ij;
/*< RFL=-1. >*/
rfl = -1.;
/*< DO 12 IP=1, KSYMP >*/
i__1 = gnd_1.ksymp;
for (ip = 1; ip <= i__1; ++ip) {
/*< IF( IP.EQ.2) IJX=1 >*/
if (ip == 2) {
ijx = 1;
}
/*< RFL=- RFL >*/
rfl = -rfl;
/*< SALPR= SALPJ* RFL >*/
salpr = dataj_1.salpj * rfl;
/*< ZIJ= ZI- RFL* ZJ >*/
zij = *zi - rfl * dataj_1.zj;
/*< ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
zp = d__1 + zij * salpr;
/*< RHOX= XIJ- CABJ* ZP >*/
rhox = xij - dataj_1.cabj * zp;
/*< RHOY= YIJ- SABJ* ZP >*/
rhoy = yij - dataj_1.sabj * zp;
/*< RHOZ= ZIJ- SALPR* ZP >*/
rhoz = zij - salpr * zp;
/*< RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI) >*/
d__2 = rhox * rhox + rhoy * rhoy;
d__1 = d__2 + rhoz * rhoz;
rh = sqrt(d__1 + *ai * *ai);
/*< IF( RH.GT.1.D-10) GOTO 1 >*/
if (rh > 1e-10) {
goto L1;
}
/*< RHOX=0. >*/
rhox = 0.;
/*< RHOY=0. >*/
rhoy = 0.;
/*< RHOZ=0. >*/
rhoz = 0.;
/*< GOTO 2 >*/
goto L2;
/*< 1 RHOX= RHOX/ RH >*/
L1:
rhox /= rh;
/*< RHOY= RHOY/ RH >*/
rhoy /= rh;
/*< RHOZ= RHOZ/ RH >*/
rhoz /= rh;
/*< 2 R= SQRT( ZP* ZP+ RH* RH) >*/
L2:
r = sqrt(zp * zp + rh * rh);
/* LUMPED CURRENT ELEMENT APPROX. FOR LARGE SEPARATIONS */
/*< IF( R.LT. RKH) GOTO 3 >*/
if (r < dataj_1.rkh) {
goto L3;
}
/*< RMAG= TP* R >*/
rmag = tp * r;
/*< CTH= ZP/ R >*/
cth = zp / r;
/*< PX= RH/ R >*/
px = rh / r;
/*< TXK= CMPLX( COS( RMAG),- SIN( RMAG)) >*/
d__1 = cos(rmag);
d__2 = -sin(rmag);
z__1.r = d__1, z__1.i = d__2;
txk->r = z__1.r, txk->i = z__1.i;
/*< PY= TP* R* R >*/
d__1 = tp * r;
py = d__1 * r;
/*< TYK= ETA* CTH* TXK* CMPLX(1.D+0,-1.D+0/ RMAG)/ PY >*/
d__1 = eta * cth;
z__3.r = d__1 * txk->r, z__3.i = d__1 * txk->i;
d__2 = -1. / rmag;
z__4.r = 1., z__4.i = d__2;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
z__1.r = z__2.r / py, z__1.i = z__2.i / py;
tyk->r = z__1.r, tyk->i = z__1.i;
/*< TZK= ETA* PX* TXK* CMPLX(1.D+0, RMAG-1.D+0/ RMAG)/(2.* PY) >*/
d__1 = eta * px;
z__3.r = d__1 * txk->r, z__3.i = d__1 * txk->i;
d__2 = rmag - 1. / rmag;
z__4.r = 1., z__4.i = d__2;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
d__3 = py * 2.;
z__1.r = z__2.r / d__3, z__1.i = z__2.i / d__3;
tzk->r = z__1.r, tzk->i = z__1.i;
/*< TEZK= TYK* CTH- TZK* PX >*/
z__2.r = cth * tyk->r, z__2.i = cth * tyk->i;
z__3.r = px * tzk->r, z__3.i = px * tzk->i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
tezk.r = z__1.r, tezk.i = z__1.i;
/*< TERK= TYK* PX+ TZK* CTH >*/
z__2.r = px * tyk->r, z__2.i = px * tyk->i;
z__3.r = cth * tzk->r, z__3.i = cth * tzk->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
terk.r = z__1.r, terk.i = z__1.i;
/*< RMAG= SIN( PI* S)/ PI >*/
rmag = sin(pi * dataj_1.s) / pi;
/*< TEZC= TEZK* RMAG >*/
z__1.r = rmag * tezk.r, z__1.i = rmag * tezk.i;
tezc.r = z__1.r, tezc.i = z__1.i;
/*< TERC= TERK* RMAG >*/
z__1.r = rmag * terk.r, z__1.i = rmag * terk.i;
terc.r = z__1.r, terc.i = z__1.i;
/*< TEZK= TEZK* S >*/
z__1.r = dataj_1.s * tezk.r, z__1.i = dataj_1.s * tezk.i;
tezk.r = z__1.r, tezk.i = z__1.i;
/*< TERK= TERK* S >*/
z__1.r = dataj_1.s * terk.r, z__1.i = dataj_1.s * terk.i;
terk.r = z__1.r, terk.i = z__1.i;
/*< TXS=(0.,0.) >*/
txs->r = 0., txs->i = 0.;
/*< TYS=(0.,0.) >*/
tys->r = 0., tys->i = 0.;
/*< TZS=(0.,0.) >*/
tzs->r = 0., tzs->i = 0.;
/*< GOTO 6 >*/
goto L6;
/* EKSC FOR THIN WIRE APPROX. OR EKSCX FOR EXTENDED T.W. APPROX.
*/
/*< 3 IF( IEXK.EQ.1) GOTO 4 >*/
L3:
if (dataj_1.iexk == 1) {
goto L4;
}
/*< >*/
eksc_(&dataj_1.s, &zp, &rh, &tp, &ijx, &tezs, &ters, &tezc, &terc, &
tezk, &terk);
/*< GOTO 5 >*/
goto L5;
/*< >*/
L4:
ekscx_(&dataj_1.b, &dataj_1.s, &zp, &rh, &tp, &ijx, &dataj_1.ind1, &
dataj_1.ind2, &tezs, &ters, &tezc, &terc, &tezk, &terk);
/*< 5 TXS= TEZS* CABJ+ TERS* RHOX >*/
L5:
z__2.r = dataj_1.cabj * tezs.r, z__2.i = dataj_1.cabj * tezs.i;
z__3.r = rhox * ters.r, z__3.i = rhox * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txs->r = z__1.r, txs->i = z__1.i;
/*< TYS= TEZS* SABJ+ TERS* RHOY >*/
z__2.r = dataj_1.sabj * tezs.r, z__2.i = dataj_1.sabj * tezs.i;
z__3.r = rhoy * ters.r, z__3.i = rhoy * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tys->r = z__1.r, tys->i = z__1.i;
/*< TZS= TEZS* SALPR+ TERS* RHOZ >*/
z__2.r = salpr * tezs.r, z__2.i = salpr * tezs.i;
z__3.r = rhoz * ters.r, z__3.i = rhoz * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzs->r = z__1.r, tzs->i = z__1.i;
/*< 6 TXK= TEZK* CABJ+ TERK* RHOX >*/
L6:
z__2.r = dataj_1.cabj * tezk.r, z__2.i = dataj_1.cabj * tezk.i;
z__3.r = rhox * terk.r, z__3.i = rhox * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txk->r = z__1.r, txk->i = z__1.i;
/*< TYK= TEZK* SABJ+ TERK* RHOY >*/
z__2.r = dataj_1.sabj * tezk.r, z__2.i = dataj_1.sabj * tezk.i;
z__3.r = rhoy * terk.r, z__3.i = rhoy * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyk->r = z__1.r, tyk->i = z__1.i;
/*< TZK= TEZK* SALPR+ TERK* RHOZ >*/
z__2.r = salpr * tezk.r, z__2.i = salpr * tezk.i;
z__3.r = rhoz * terk.r, z__3.i = rhoz * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzk->r = z__1.r, tzk->i = z__1.i;
/*< TXC= TEZC* CABJ+ TERC* RHOX >*/
z__2.r = dataj_1.cabj * tezc.r, z__2.i = dataj_1.cabj * tezc.i;
z__3.r = rhox * terc.r, z__3.i = rhox * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txc->r = z__1.r, txc->i = z__1.i;
/*< TYC= TEZC* SABJ+ TERC* RHOY >*/
z__2.r = dataj_1.sabj * tezc.r, z__2.i = dataj_1.sabj * tezc.i;
z__3.r = rhoy * terc.r, z__3.i = rhoy * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyc->r = z__1.r, tyc->i = z__1.i;
/*< TZC= TEZC* SALPR+ TERC* RHOZ >*/
z__2.r = salpr * tezc.r, z__2.i = salpr * tezc.i;
z__3.r = rhoz * terc.r, z__3.i = rhoz * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzc->r = z__1.r, tzc->i = z__1.i;
/*< IF( IP.NE.2) GOTO 11 >*/
if (ip != 2) {
goto L11;
}
/*< IF( IPERF.GT.0) GOTO 10 >*/
if (gnd_1.iperf > 0) {
goto L10;
}
/*< ZRATX= ZRATI >*/
zratx.r = gnd_1.zrati.r, zratx.i = gnd_1.zrati.i;
/*< RMAG= R >*/
rmag = r;
/* SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. */
/*< XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ) >*/
xymag = sqrt(xij * xij + yij * yij);
/*< IF( NRADL.EQ.0) GOTO 7 >*/
if (gnd_1.nradl == 0) {
goto L7;
}
/*< XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ) >*/
xspec = (*xi * dataj_1.zj + *zi * dataj_1.xj) / (*zi + dataj_1.zj);
/*< YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ) >*/
yspec = (*yi * dataj_1.zj + *zi * dataj_1.yj) / (*zi + dataj_1.zj);
/*< RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2) >*/
d__1 = xspec * xspec + yspec * yspec;
rhospc = sqrt(d__1 + gnd_1.t2 * gnd_1.t2);
/*< IF( RHOSPC.GT. SCRWL) GOTO 7 >*/
if (rhospc > gnd_1.scrwl) {
goto L7;
}
/*< ZSCRN= T1* RHOSPC* LOG( RHOSPC/ T2) >*/
z__2.r = rhospc * gnd_1.t1.r, z__2.i = rhospc * gnd_1.t1.i;
d__1 = log(rhospc / gnd_1.t2);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
zscrn.r = z__1.r, zscrn.i = z__1.i;
/*< ZRATX=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN) >*/
z__2.r = zscrn.r * gnd_1.zrati.r - zscrn.i * gnd_1.zrati.i, z__2.i =
zscrn.r * gnd_1.zrati.i + zscrn.i * gnd_1.zrati.r;
z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
z__3.r = z__4.r + zscrn.r, z__3.i = z__4.i + zscrn.i;
z_div(&z__1, &z__2, &z__3);
zratx.r = z__1.r, zratx.i = z__1.i;
/* CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED
. */
/*< 7 IF( XYMAG.GT.1.D-6) GOTO 8 >*/
L7:
if (xymag > 1e-6) {
goto L8;
}
/*< PX=0. >*/
px = 0.;
/*< PY=0. >*/
py = 0.;
/*< CTH=1. >*/
cth = 1.;
/*< ZRSIN=(1.,0.) >*/
zrsin.r = 1., zrsin.i = 0.;
/*< GOTO 9 >*/
goto L9;
/*< 8 PX=- YIJ/ XYMAG >*/
L8:
px = -yij / xymag;
/*< PY= XIJ/ XYMAG >*/
py = xij / xymag;
/*< CTH= ZIJ/ RMAG >*/
cth = zij / rmag;
/*< ZRSIN= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH)) >*/
z__4.r = zratx.r * zratx.r - zratx.i * zratx.i, z__4.i = zratx.r *
zratx.i + zratx.i * zratx.r;
d__1 = 1. - cth * cth;
z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
zrsin.r = z__1.r, zrsin.i = z__1.i;
/*< 9 REFS=( CTH- ZRATX* ZRSIN)/( CTH+ ZRATX* ZRSIN) >*/
L9:
z__3.r = zratx.r * zrsin.r - zratx.i * zrsin.i, z__3.i = zratx.r *
zrsin.i + zratx.i * zrsin.r;
z__2.r = cth - z__3.r, z__2.i = -z__3.i;
z__5.r = zratx.r * zrsin.r - zratx.i * zrsin.i, z__5.i = zratx.r *
zrsin.i + zratx.i * zrsin.r;
z__4.r = cth + z__5.r, z__4.i = z__5.i;
z_div(&z__1, &z__2, &z__4);
refs.r = z__1.r, refs.i = z__1.i;
/*< REFPS=-( ZRATX* CTH- ZRSIN)/( ZRATX* CTH+ ZRSIN) >*/
z__4.r = cth * zratx.r, z__4.i = cth * zratx.i;
z__3.r = z__4.r - zrsin.r, z__3.i = z__4.i - zrsin.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__6.r = cth * zratx.r, z__6.i = cth * zratx.i;
z__5.r = z__6.r + zrsin.r, z__5.i = z__6.i + zrsin.i;
z_div(&z__1, &z__2, &z__5);
refps.r = z__1.r, refps.i = z__1.i;
/*< REFPS= REFPS- REFS >*/
z__1.r = refps.r - refs.r, z__1.i = refps.i - refs.i;
refps.r = z__1.r, refps.i = z__1.i;
/*< EPY= PX* TXK+ PY* TYK >*/
z__2.r = px * txk->r, z__2.i = px * txk->i;
z__3.r = py * tyk->r, z__3.i = py * tyk->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< EPX= PX* EPY >*/
z__1.r = px * epy.r, z__1.i = px * epy.i;
epx.r = z__1.r, epx.i = z__1.i;
/*< EPY= PY* EPY >*/
z__1.r = py * epy.r, z__1.i = py * epy.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< TXK= REFS* TXK+ REFPS* EPX >*/
z__2.r = refs.r * txk->r - refs.i * txk->i, z__2.i = refs.r * txk->i
+ refs.i * txk->r;
z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i
+ refps.i * epx.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txk->r = z__1.r, txk->i = z__1.i;
/*< TYK= REFS* TYK+ REFPS* EPY >*/
z__2.r = refs.r * tyk->r - refs.i * tyk->i, z__2.i = refs.r * tyk->i
+ refs.i * tyk->r;
z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i
+ refps.i * epy.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyk->r = z__1.r, tyk->i = z__1.i;
/*< TZK= REFS* TZK >*/
z__1.r = refs.r * tzk->r - refs.i * tzk->i, z__1.i = refs.r * tzk->i
+ refs.i * tzk->r;
tzk->r = z__1.r, tzk->i = z__1.i;
/*< EPY= PX* TXS+ PY* TYS >*/
z__2.r = px * txs->r, z__2.i = px * txs->i;
z__3.r = py * tys->r, z__3.i = py * tys->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< EPX= PX* EPY >*/
z__1.r = px * epy.r, z__1.i = px * epy.i;
epx.r = z__1.r, epx.i = z__1.i;
/*< EPY= PY* EPY >*/
z__1.r = py * epy.r, z__1.i = py * epy.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< TXS= REFS* TXS+ REFPS* EPX >*/
z__2.r = refs.r * txs->r - refs.i * txs->i, z__2.i = refs.r * txs->i
+ refs.i * txs->r;
z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i
+ refps.i * epx.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txs->r = z__1.r, txs->i = z__1.i;
/*< TYS= REFS* TYS+ REFPS* EPY >*/
z__2.r = refs.r * tys->r - refs.i * tys->i, z__2.i = refs.r * tys->i
+ refs.i * tys->r;
z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i
+ refps.i * epy.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tys->r = z__1.r, tys->i = z__1.i;
/*< TZS= REFS* TZS >*/
z__1.r = refs.r * tzs->r - refs.i * tzs->i, z__1.i = refs.r * tzs->i
+ refs.i * tzs->r;
tzs->r = z__1.r, tzs->i = z__1.i;
/*< EPY= PX* TXC+ PY* TYC >*/
z__2.r = px * txc->r, z__2.i = px * txc->i;
z__3.r = py * tyc->r, z__3.i = py * tyc->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< EPX= PX* EPY >*/
z__1.r = px * epy.r, z__1.i = px * epy.i;
epx.r = z__1.r, epx.i = z__1.i;
/*< EPY= PY* EPY >*/
z__1.r = py * epy.r, z__1.i = py * epy.i;
epy.r = z__1.r, epy.i = z__1.i;
/*< TXC= REFS* TXC+ REFPS* EPX >*/
z__2.r = refs.r * txc->r - refs.i * txc->i, z__2.i = refs.r * txc->i
+ refs.i * txc->r;
z__3.r = refps.r * epx.r - refps.i * epx.i, z__3.i = refps.r * epx.i
+ refps.i * epx.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txc->r = z__1.r, txc->i = z__1.i;
/*< TYC= REFS* TYC+ REFPS* EPY >*/
z__2.r = refs.r * tyc->r - refs.i * tyc->i, z__2.i = refs.r * tyc->i
+ refs.i * tyc->r;
z__3.r = refps.r * epy.r - refps.i * epy.i, z__3.i = refps.r * epy.i
+ refps.i * epy.r;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyc->r = z__1.r, tyc->i = z__1.i;
/*< TZC= REFS* TZC >*/
z__1.r = refs.r * tzc->r - refs.i * tzc->i, z__1.i = refs.r * tzc->i
+ refs.i * tzc->r;
tzc->r = z__1.r, tzc->i = z__1.i;
/*< 10 EXK= EXK- TXK* FRATI >*/
L10:
z__2.r = txk->r * gnd_1.frati.r - txk->i * gnd_1.frati.i, z__2.i =
txk->r * gnd_1.frati.i + txk->i * gnd_1.frati.r;
z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK- TYK* FRATI >*/
z__2.r = tyk->r * gnd_1.frati.r - tyk->i * gnd_1.frati.i, z__2.i =
tyk->r * gnd_1.frati.i + tyk->i * gnd_1.frati.r;
z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK- TZK* FRATI >*/
z__2.r = tzk->r * gnd_1.frati.r - tzk->i * gnd_1.frati.i, z__2.i =
tzk->r * gnd_1.frati.i + tzk->i * gnd_1.frati.r;
z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= EXS- TXS* FRATI >*/
z__2.r = txs->r * gnd_1.frati.r - txs->i * gnd_1.frati.i, z__2.i =
txs->r * gnd_1.frati.i + txs->i * gnd_1.frati.r;
z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS- TYS* FRATI >*/
z__2.r = tys->r * gnd_1.frati.r - tys->i * gnd_1.frati.i, z__2.i =
tys->r * gnd_1.frati.i + tys->i * gnd_1.frati.r;
z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS- TZS* FRATI >*/
z__2.r = tzs->r * gnd_1.frati.r - tzs->i * gnd_1.frati.i, z__2.i =
tzs->r * gnd_1.frati.i + tzs->i * gnd_1.frati.r;
z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< EXC= EXC- TXC* FRATI >*/
z__2.r = txc->r * gnd_1.frati.r - txc->i * gnd_1.frati.i, z__2.i =
txc->r * gnd_1.frati.i + txc->i * gnd_1.frati.r;
z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= EYC- TYC* FRATI >*/
z__2.r = tyc->r * gnd_1.frati.r - tyc->i * gnd_1.frati.i, z__2.i =
tyc->r * gnd_1.frati.i + tyc->i * gnd_1.frati.r;
z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= EZC- TZC* FRATI >*/
z__2.r = tzc->r * gnd_1.frati.r - tzc->i * gnd_1.frati.i, z__2.i =
tzc->r * gnd_1.frati.i + tzc->i * gnd_1.frati.r;
z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< GOTO 12 >*/
goto L12;
/*< 11 EXK= TXK >*/
L11:
dataj_1.exk.r = txk->r, dataj_1.exk.i = txk->i;
/*< EYK= TYK >*/
dataj_1.eyk.r = tyk->r, dataj_1.eyk.i = tyk->i;
/*< EZK= TZK >*/
dataj_1.ezk.r = tzk->r, dataj_1.ezk.i = tzk->i;
/*< EXS= TXS >*/
dataj_1.exs.r = txs->r, dataj_1.exs.i = txs->i;
/*< EYS= TYS >*/
dataj_1.eys.r = tys->r, dataj_1.eys.i = tys->i;
/*< EZS= TZS >*/
dataj_1.ezs.r = tzs->r, dataj_1.ezs.i = tzs->i;
/*< EXC= TXC >*/
dataj_1.exc.r = txc->r, dataj_1.exc.i = txc->i;
/*< EYC= TYC >*/
dataj_1.eyc.r = tyc->r, dataj_1.eyc.i = tyc->i;
/*< EZC= TZC >*/
dataj_1.ezc.r = tzc->r, dataj_1.ezc.i = tzc->i;
/*< 12 CONTINUE >*/
L12:
;
}
/*< IF( IPERF.EQ.2) GOTO 13 >*/
if (gnd_1.iperf == 2) {
goto L13;
}
/* FIELD DUE TO GROUND USING SOMMERFELD/NORTON */
/*< RETURN >*/
return 0;
/*< 13 SN= SQRT( CABJ* CABJ+ SABJ* SABJ) >*/
L13:
incom_1.sn = sqrt(dataj_1.cabj * dataj_1.cabj + dataj_1.sabj *
dataj_1.sabj);
/*< IF( SN.LT.1.D-5) GOTO 14 >*/
if (incom_1.sn < 1e-5) {
goto L14;
}
/*< XSN= CABJ/ SN >*/
incom_1.xsn = dataj_1.cabj / incom_1.sn;
/*< YSN= SABJ/ SN >*/
incom_1.ysn = dataj_1.sabj / incom_1.sn;
/*< GOTO 15 >*/
goto L15;
/*< 14 SN=0. >*/
L14:
incom_1.sn = 0.;
/*< XSN=1. >*/
incom_1.xsn = 1.;
/* DISPLACE OBSERVATION POINT FOR THIN WIRE APPROXIMATION */
/*< YSN=0. >*/
incom_1.ysn = 0.;
/*< 15 ZIJ= ZI+ ZJ >*/
L15:
zij = *zi + dataj_1.zj;
/*< SALPR=- SALPJ >*/
salpr = -dataj_1.salpj;
/*< RHOX= SABJ* ZIJ- SALPR* YIJ >*/
rhox = dataj_1.sabj * zij - salpr * yij;
/*< RHOY= SALPR* XIJ- CABJ* ZIJ >*/
rhoy = salpr * xij - dataj_1.cabj * zij;
/*< RHOZ= CABJ* YIJ- SABJ* XIJ >*/
rhoz = dataj_1.cabj * yij - dataj_1.sabj * xij;
/*< RH= RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ >*/
d__1 = rhox * rhox + rhoy * rhoy;
rh = d__1 + rhoz * rhoz;
/*< IF( RH.GT.1.D-10) GOTO 16 >*/
if (rh > 1e-10) {
goto L16;
}
/*< XO= XI- AI* YSN >*/
incom_1.xo = *xi - *ai * incom_1.ysn;
/*< YO= YI+ AI* XSN >*/
incom_1.yo = *yi + *ai * incom_1.xsn;
/*< ZO= ZI >*/
incom_1.zo = *zi;
/*< GOTO 17 >*/
goto L17;
/*< 16 RH= AI/ SQRT( RH) >*/
L16:
rh = *ai / sqrt(rh);
/*< IF( RHOZ.LT.0.) RH=- RH >*/
if (rhoz < 0.) {
rh = -rh;
}
/*< XO= XI+ RH* RHOX >*/
incom_1.xo = *xi + rh * rhox;
/*< YO= YI+ RH* RHOY >*/
incom_1.yo = *yi + rh * rhoy;
/*< ZO= ZI+ RH* RHOZ >*/
incom_1.zo = *zi + rh * rhoz;
/*< 17 R= XIJ* XIJ+ YIJ* YIJ+ ZIJ* ZIJ >*/
L17:
d__1 = xij * xij + yij * yij;
r = d__1 + zij * zij;
/* FIELD FROM INTERPOLATION IS INTEGRATED OVER SEGMENT */
/*< IF( R.GT..95) GOTO 18 >*/
if (r > .95) {
goto L18;
}
/*< ISNOR=1 >*/
incom_1.isnor = 1;
/*< DMIN= EXK* CONJG( EXK)+ EYK* CONJG( EYK)+ EZK* CONJG( EZK) >*/
d_cnjg(&z__4, &dataj_1.exk);
z__3.r = dataj_1.exk.r * z__4.r - dataj_1.exk.i * z__4.i, z__3.i =
dataj_1.exk.r * z__4.i + dataj_1.exk.i * z__4.r;
d_cnjg(&z__6, &dataj_1.eyk);
z__5.r = dataj_1.eyk.r * z__6.r - dataj_1.eyk.i * z__6.i, z__5.i =
dataj_1.eyk.r * z__6.i + dataj_1.eyk.i * z__6.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
d_cnjg(&z__8, &dataj_1.ezk);
z__7.r = dataj_1.ezk.r * z__8.r - dataj_1.ezk.i * z__8.i, z__7.i =
dataj_1.ezk.r * z__8.i + dataj_1.ezk.i * z__8.r;
z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i;
dmin_ = z__1.r;
/*< DMIN=.01* SQRT( DMIN) >*/
dmin_ = sqrt(dmin_) * .01;
/*< SHAF=.5* S >*/
shaf = dataj_1.s * .5;
/*< CALL ROM2(- SHAF, SHAF, EGND, DMIN) >*/
d__1 = -shaf;
rom2_(&d__1, &shaf, egnd, &dmin_);
/* NORTON FIELD EQUATIONS AND LUMPED CURRENT ELEMENT APPROXIMATION */
/*< GOTO 19 >*/
goto L19;
/*< 18 ISNOR=2 >*/
L18:
incom_1.isnor = 2;
/*< CALL SFLDS(0., EGND) >*/
sflds_(&c_b594, egnd);
/*< GOTO 22 >*/
goto L22;
/*< 19 ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
L19:
d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
zp = d__1 + zij * salpr;
/*< RH= R- ZP* ZP >*/
rh = r - zp * zp;
/*< IF( RH.GT.1.D-10) GOTO 20 >*/
if (rh > 1e-10) {
goto L20;
}
/*< DMIN=0. >*/
dmin_ = 0.;
/*< GOTO 21 >*/
goto L21;
/*< 20 DMIN= SQRT( RH/( RH+ AI* AI)) >*/
L20:
dmin_ = sqrt(rh / (rh + *ai * *ai));
/*< 21 IF( DMIN.GT..95) GOTO 22 >*/
L21:
if (dmin_ > .95) {
goto L22;
}
/*< PX=1.- DMIN >*/
px = 1. - dmin_;
/*< TERK=( TXK* CABJ+ TYK* SABJ+ TZK* SALPR)* PX >*/
z__4.r = dataj_1.cabj * txk->r, z__4.i = dataj_1.cabj * txk->i;
z__5.r = dataj_1.sabj * tyk->r, z__5.i = dataj_1.sabj * tyk->i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = salpr * tzk->r, z__6.i = salpr * tzk->i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = px * z__2.r, z__1.i = px * z__2.i;
terk.r = z__1.r, terk.i = z__1.i;
/*< TXK= DMIN* TXK+ TERK* CABJ >*/
z__2.r = dmin_ * txk->r, z__2.i = dmin_ * txk->i;
z__3.r = dataj_1.cabj * terk.r, z__3.i = dataj_1.cabj * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txk->r = z__1.r, txk->i = z__1.i;
/*< TYK= DMIN* TYK+ TERK* SABJ >*/
z__2.r = dmin_ * tyk->r, z__2.i = dmin_ * tyk->i;
z__3.r = dataj_1.sabj * terk.r, z__3.i = dataj_1.sabj * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyk->r = z__1.r, tyk->i = z__1.i;
/*< TZK= DMIN* TZK+ TERK* SALPR >*/
z__2.r = dmin_ * tzk->r, z__2.i = dmin_ * tzk->i;
z__3.r = salpr * terk.r, z__3.i = salpr * terk.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzk->r = z__1.r, tzk->i = z__1.i;
/*< TERS=( TXS* CABJ+ TYS* SABJ+ TZS* SALPR)* PX >*/
z__4.r = dataj_1.cabj * txs->r, z__4.i = dataj_1.cabj * txs->i;
z__5.r = dataj_1.sabj * tys->r, z__5.i = dataj_1.sabj * tys->i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = salpr * tzs->r, z__6.i = salpr * tzs->i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = px * z__2.r, z__1.i = px * z__2.i;
ters.r = z__1.r, ters.i = z__1.i;
/*< TXS= DMIN* TXS+ TERS* CABJ >*/
z__2.r = dmin_ * txs->r, z__2.i = dmin_ * txs->i;
z__3.r = dataj_1.cabj * ters.r, z__3.i = dataj_1.cabj * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txs->r = z__1.r, txs->i = z__1.i;
/*< TYS= DMIN* TYS+ TERS* SABJ >*/
z__2.r = dmin_ * tys->r, z__2.i = dmin_ * tys->i;
z__3.r = dataj_1.sabj * ters.r, z__3.i = dataj_1.sabj * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tys->r = z__1.r, tys->i = z__1.i;
/*< TZS= DMIN* TZS+ TERS* SALPR >*/
z__2.r = dmin_ * tzs->r, z__2.i = dmin_ * tzs->i;
z__3.r = salpr * ters.r, z__3.i = salpr * ters.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzs->r = z__1.r, tzs->i = z__1.i;
/*< TERC=( TXC* CABJ+ TYC* SABJ+ TZC* SALPR)* PX >*/
z__4.r = dataj_1.cabj * txc->r, z__4.i = dataj_1.cabj * txc->i;
z__5.r = dataj_1.sabj * tyc->r, z__5.i = dataj_1.sabj * tyc->i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = salpr * tzc->r, z__6.i = salpr * tzc->i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = px * z__2.r, z__1.i = px * z__2.i;
terc.r = z__1.r, terc.i = z__1.i;
/*< TXC= DMIN* TXC+ TERC* CABJ >*/
z__2.r = dmin_ * txc->r, z__2.i = dmin_ * txc->i;
z__3.r = dataj_1.cabj * terc.r, z__3.i = dataj_1.cabj * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
txc->r = z__1.r, txc->i = z__1.i;
/*< TYC= DMIN* TYC+ TERC* SABJ >*/
z__2.r = dmin_ * tyc->r, z__2.i = dmin_ * tyc->i;
z__3.r = dataj_1.sabj * terc.r, z__3.i = dataj_1.sabj * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tyc->r = z__1.r, tyc->i = z__1.i;
/*< TZC= DMIN* TZC+ TERC* SALPR >*/
z__2.r = dmin_ * tzc->r, z__2.i = dmin_ * tzc->i;
z__3.r = salpr * terc.r, z__3.i = salpr * terc.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
tzc->r = z__1.r, tzc->i = z__1.i;
/*< 22 EXK= EXK+ TXK >*/
L22:
z__1.r = dataj_1.exk.r + txk->r, z__1.i = dataj_1.exk.i + txk->i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK+ TYK >*/
z__1.r = dataj_1.eyk.r + tyk->r, z__1.i = dataj_1.eyk.i + tyk->i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK+ TZK >*/
z__1.r = dataj_1.ezk.r + tzk->r, z__1.i = dataj_1.ezk.i + tzk->i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= EXS+ TXS >*/
z__1.r = dataj_1.exs.r + txs->r, z__1.i = dataj_1.exs.i + txs->i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS+ TYS >*/
z__1.r = dataj_1.eys.r + tys->r, z__1.i = dataj_1.eys.i + tys->i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS+ TZS >*/
z__1.r = dataj_1.ezs.r + tzs->r, z__1.i = dataj_1.ezs.i + tzs->i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< EXC= EXC+ TXC >*/
z__1.r = dataj_1.exc.r + txc->r, z__1.i = dataj_1.exc.i + txc->i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= EYC+ TYC >*/
z__1.r = dataj_1.eyc.r + tyc->r, z__1.i = dataj_1.eyc.i + tyc->i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= EZC+ TZC >*/
z__1.r = dataj_1.ezc.r + tzc->r, z__1.i = dataj_1.ezc.i + tzc->i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* efld_ */
#undef tzs
#undef tys
#undef txs
#undef tzk
#undef tyk
#undef txk
#undef tzc
#undef tyc
#undef txc
#undef egnd
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE EKSC( S, Z, RH, XK, IJ, EZS, ERS, EZC, ERC, EZK, ERK) >*/
/* Subroutine */ int eksc_(s, z, rh, xk, ij, ezs, ers, ezc, erc, ezk, erk)
doublereal *s, *z, *rh, *xk;
integer *ij;
doublecomplex *ezs, *ers, *ezc, *erc, *ezk, *erk;
{
/* Initialized data */
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 4.771341189, 0. };
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
z__11, z__12, z__13;
/* Builtin functions */
double sin(), cos();
/* Local variables */
static doublereal cint;
#define conx ((doublereal *)&equiv_0)
static doublereal sint;
extern /* Subroutine */ int intx_();
static doublereal z1, z2, cs, sh;
extern /* Subroutine */ int gx_();
static doublereal ss;
static doublecomplex gp1, gp2, gz1, gz2;
#define con ((doublecomplex *)&equiv_0)
static doublereal rhk, shk;
static doublecomplex gzp1, gzp2;
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/* COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
*/
/* THIN WIRE APPROXIMATION. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /TMI/ ZPK, RKB2, IJX >*/
/*< DIMENSION CONX(2) >*/
/*< EQUIVALENCE(CONX,CON) >*/
/*< DATA CONX/0.,4.771341189D+0/ >*/
/*< IJX= IJ >*/
tmi_1.ijx = *ij;
/*< ZPK= XK* Z >*/
tmi_1.zpk = *xk * *z;
/*< RHK= XK* RH >*/
rhk = *xk * *rh;
/*< RKB2= RHK* RHK >*/
tmi_1.rkb2 = rhk * rhk;
/*< SH=.5* S >*/
sh = *s * .5;
/*< SHK= XK* SH >*/
shk = *xk * sh;
/*< SS= SIN( SHK) >*/
ss = sin(shk);
/*< CS= COS( SHK) >*/
cs = cos(shk);
/*< Z2= SH- Z >*/
z2 = sh - *z;
/*< Z1=-( SH+ Z) >*/
z1 = -(sh + *z);
/*< CALL GX( Z1, RH, XK, GZ1, GP1) >*/
gx_(&z1, rh, xk, &gz1, &gp1);
/*< CALL GX( Z2, RH, XK, GZ2, GP2) >*/
gx_(&z2, rh, xk, &gz2, &gp2);
/*< GZP1= GP1* Z1 >*/
z__1.r = z1 * gp1.r, z__1.i = z1 * gp1.i;
gzp1.r = z__1.r, gzp1.i = z__1.i;
/*< GZP2= GP2* Z2 >*/
z__1.r = z2 * gp2.r, z__1.i = z2 * gp2.i;
gzp2.r = z__1.r, gzp2.i = z__1.i;
/*< EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS) >*/
z__5.r = gz2.r - gz1.r, z__5.i = gz2.i - gz1.i;
z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
z__3.r = *xk * z__4.r, z__3.i = *xk * z__4.i;
z__7.r = gzp2.r + gzp1.r, z__7.i = gzp2.i + gzp1.i;
z__6.r = ss * z__7.r, z__6.i = ss * z__7.i;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i +
con->i * z__2.r;
ezs->r = z__1.r, ezs->i = z__1.i;
/*< EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS) >*/
z__2.r = -con->r, z__2.i = -con->i;
z__6.r = gz2.r + gz1.r, z__6.i = gz2.i + gz1.i;
z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
z__4.r = *xk * z__5.r, z__4.i = *xk * z__5.i;
z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
z__7.r = cs * z__8.r, z__7.i = cs * z__8.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
ezc->r = z__1.r, ezc->i = z__1.i;
/*< ERK= CON*( GP2- GP1)* RH >*/
z__3.r = gp2.r - gp1.r, z__3.i = gp2.i - gp1.i;
z__2.r = con->r * z__3.r - con->i * z__3.i, z__2.i = con->r * z__3.i +
con->i * z__3.r;
z__1.r = *rh * z__2.r, z__1.i = *rh * z__2.i;
erk->r = z__1.r, erk->i = z__1.i;
/*< CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT) >*/
d__1 = -shk;
intx_(&d__1, &shk, &rhk, ij, &cint, &sint);
/*< EZK=- CON*( GZP2- GZP1+ XK* XK* CMPLX( CINT,- SINT)) >*/
z__2.r = -con->r, z__2.i = -con->i;
z__4.r = gzp2.r - gzp1.r, z__4.i = gzp2.i - gzp1.i;
d__1 = *xk * *xk;
d__2 = -sint;
z__6.r = cint, z__6.i = d__2;
z__5.r = d__1 * z__6.r, z__5.i = d__1 * z__6.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
ezk->r = z__1.r, ezk->i = z__1.i;
/*< GZP1= GZP1* Z1 >*/
z__1.r = z1 * gzp1.r, z__1.i = z1 * gzp1.i;
gzp1.r = z__1.r, gzp1.i = z__1.i;
/*< GZP2= GZP2* Z2 >*/
z__1.r = z2 * gzp2.r, z__1.i = z2 * gzp2.i;
gzp2.r = z__1.r, gzp2.i = z__1.i;
/*< IF( RH.LT.1.D-10) GOTO 1 >*/
if (*rh < 1e-10) {
goto L1;
}
/*< >*/
z__3.r = -con->r, z__3.i = -con->i;
z__8.r = gzp2.r + gzp1.r, z__8.i = gzp2.i + gzp1.i;
z__7.r = z__8.r + gz2.r, z__7.i = z__8.i + gz2.i;
z__6.r = z__7.r + gz1.r, z__6.i = z__7.i + gz1.i;
z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
z__12.r = z2 * gz2.r, z__12.i = z2 * gz2.i;
z__13.r = z1 * gz1.r, z__13.i = z1 * gz1.i;
z__11.r = z__12.r - z__13.r, z__11.i = z__12.i - z__13.i;
z__10.r = cs * z__11.r, z__10.i = cs * z__11.i;
z__9.r = *xk * z__10.r, z__9.i = *xk * z__10.i;
z__4.r = z__5.r - z__9.r, z__4.i = z__5.i - z__9.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i +
z__3.i * z__4.r;
z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
ers->r = z__1.r, ers->i = z__1.i;
/*< >*/
z__3.r = -con->r, z__3.i = -con->i;
z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
z__7.r = z__8.r + gz2.r, z__7.i = z__8.i + gz2.i;
z__6.r = z__7.r - gz1.r, z__6.i = z__7.i - gz1.i;
z__5.r = cs * z__6.r, z__5.i = cs * z__6.i;
z__12.r = z2 * gz2.r, z__12.i = z2 * gz2.i;
z__13.r = z1 * gz1.r, z__13.i = z1 * gz1.i;
z__11.r = z__12.r + z__13.r, z__11.i = z__12.i + z__13.i;
z__10.r = ss * z__11.r, z__10.i = ss * z__11.i;
z__9.r = *xk * z__10.r, z__9.i = *xk * z__10.i;
z__4.r = z__5.r + z__9.r, z__4.i = z__5.i + z__9.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i +
z__3.i * z__4.r;
z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
erc->r = z__1.r, erc->i = z__1.i;
/*< RETURN >*/
return 0;
/*< 1 ERS=(0.,0.) >*/
L1:
ers->r = 0., ers->i = 0.;
/*< ERC=(0.,0.) >*/
erc->r = 0., erc->i = 0.;
/*< RETURN >*/
return 0;
/*< END >*/
} /* eksc_ */
#undef con
#undef conx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int ekscx_(bx, s, z, rhx, xk, ij, inx1, inx2, ezs, ers, ezc,
erc, ezk, erk)
doublereal *bx, *s, *z, *rhx, *xk;
integer *ij, *inx1, *inx2;
doublecomplex *ezs, *ers, *ezc, *erc, *ezk, *erk;
{
/* Initialized data */
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 4.771341189, 0. };
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
z__11, z__12, z__13, z__14;
/* Builtin functions */
double sin(), cos();
/* Local variables */
static doublereal cint;
#define conx ((doublereal *)&equiv_0)
static doublereal sint;
extern /* Subroutine */ int intx_();
static doublereal b, a2, z1, z2, bk, cs, rh, sh;
extern /* Subroutine */ int gx_();
static doublereal ss, bk2;
static doublecomplex gr1, gr2, gz1, gz2;
static integer ira;
#define con ((doublecomplex *)&equiv_0)
static doublereal rhk, shk;
extern /* Subroutine */ int gxx_();
static doublecomplex grk1, grk2, grp1, grp2, gzp1, gzp2, gzz1, gzz2;
/* *** */
/* COMPUTE E FIELD OF SINE, COSINE, AND CONSTANT CURRENT FILAMENTS BY
*/
/* EXTENDED THIN WIRE APPROXIMATION. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /TMI/ ZPK, RKB2, IJX >*/
/*< DIMENSION CONX(2) >*/
/*< EQUIVALENCE(CONX,CON) >*/
/*< DATA CONX/0.,4.771341189D+0/ >*/
/*< IF( RHX.LT. BX) GOTO 1 >*/
if (*rhx < *bx) {
goto L1;
}
/*< RH= RHX >*/
rh = *rhx;
/*< B= BX >*/
b = *bx;
/*< IRA=0 >*/
ira = 0;
/*< GOTO 2 >*/
goto L2;
/*< 1 RH= BX >*/
L1:
rh = *bx;
/*< B= RHX >*/
b = *rhx;
/*< IRA=1 >*/
ira = 1;
/*< 2 SH=.5* S >*/
L2:
sh = *s * .5;
/*< IJX= IJ >*/
tmi_1.ijx = *ij;
/*< ZPK= XK* Z >*/
tmi_1.zpk = *xk * *z;
/*< RHK= XK* RH >*/
rhk = *xk * rh;
/*< RKB2= RHK* RHK >*/
tmi_1.rkb2 = rhk * rhk;
/*< SHK= XK* SH >*/
shk = *xk * sh;
/*< SS= SIN( SHK) >*/
ss = sin(shk);
/*< CS= COS( SHK) >*/
cs = cos(shk);
/*< Z2= SH- Z >*/
z2 = sh - *z;
/*< Z1=-( SH+ Z) >*/
z1 = -(sh + *z);
/*< A2= B* B >*/
a2 = b * b;
/*< IF( INX1.EQ.2) GOTO 3 >*/
if (*inx1 == 2) {
goto L3;
}
/*< >*/
gxx_(&z1, &rh, &b, &a2, xk, &ira, &gz1, &gzp1, &gr1, &grp1, &grk1, &gzz1);
/*< GOTO 4 >*/
goto L4;
/*< 3 CALL GX( Z1, RHX, XK, GZ1, GRK1) >*/
L3:
gx_(&z1, rhx, xk, &gz1, &grk1);
/*< GZP1= GRK1* Z1 >*/
z__1.r = z1 * grk1.r, z__1.i = z1 * grk1.i;
gzp1.r = z__1.r, gzp1.i = z__1.i;
/*< GR1= GZ1/ RHX >*/
z__1.r = gz1.r / *rhx, z__1.i = gz1.i / *rhx;
gr1.r = z__1.r, gr1.i = z__1.i;
/*< GRP1= GZP1/ RHX >*/
z__1.r = gzp1.r / *rhx, z__1.i = gzp1.i / *rhx;
grp1.r = z__1.r, grp1.i = z__1.i;
/*< GRK1= GRK1* RHX >*/
z__1.r = *rhx * grk1.r, z__1.i = *rhx * grk1.i;
grk1.r = z__1.r, grk1.i = z__1.i;
/*< GZZ1=(0.,0.) >*/
gzz1.r = 0., gzz1.i = 0.;
/*< 4 IF( INX2.EQ.2) GOTO 5 >*/
L4:
if (*inx2 == 2) {
goto L5;
}
/*< >*/
gxx_(&z2, &rh, &b, &a2, xk, &ira, &gz2, &gzp2, &gr2, &grp2, &grk2, &gzz2);
/*< GOTO 6 >*/
goto L6;
/*< 5 CALL GX( Z2, RHX, XK, GZ2, GRK2) >*/
L5:
gx_(&z2, rhx, xk, &gz2, &grk2);
/*< GZP2= GRK2* Z2 >*/
z__1.r = z2 * grk2.r, z__1.i = z2 * grk2.i;
gzp2.r = z__1.r, gzp2.i = z__1.i;
/*< GR2= GZ2/ RHX >*/
z__1.r = gz2.r / *rhx, z__1.i = gz2.i / *rhx;
gr2.r = z__1.r, gr2.i = z__1.i;
/*< GRP2= GZP2/ RHX >*/
z__1.r = gzp2.r / *rhx, z__1.i = gzp2.i / *rhx;
grp2.r = z__1.r, grp2.i = z__1.i;
/*< GRK2= GRK2* RHX >*/
z__1.r = *rhx * grk2.r, z__1.i = *rhx * grk2.i;
grk2.r = z__1.r, grk2.i = z__1.i;
/*< GZZ2=(0.,0.) >*/
gzz2.r = 0., gzz2.i = 0.;
/*< 6 EZS= CON*(( GZ2- GZ1)* CS* XK-( GZP2+ GZP1)* SS) >*/
L6:
z__5.r = gz2.r - gz1.r, z__5.i = gz2.i - gz1.i;
z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
z__3.r = *xk * z__4.r, z__3.i = *xk * z__4.i;
z__7.r = gzp2.r + gzp1.r, z__7.i = gzp2.i + gzp1.i;
z__6.r = ss * z__7.r, z__6.i = ss * z__7.i;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i +
con->i * z__2.r;
ezs->r = z__1.r, ezs->i = z__1.i;
/*< EZC=- CON*(( GZ2+ GZ1)* SS* XK+( GZP2- GZP1)* CS) >*/
z__2.r = -con->r, z__2.i = -con->i;
z__6.r = gz2.r + gz1.r, z__6.i = gz2.i + gz1.i;
z__5.r = ss * z__6.r, z__5.i = ss * z__6.i;
z__4.r = *xk * z__5.r, z__4.i = *xk * z__5.i;
z__8.r = gzp2.r - gzp1.r, z__8.i = gzp2.i - gzp1.i;
z__7.r = cs * z__8.r, z__7.i = cs * z__8.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
ezc->r = z__1.r, ezc->i = z__1.i;
/*< >*/
z__2.r = -con->r, z__2.i = -con->i;
z__8.r = z2 * grp2.r, z__8.i = z2 * grp2.i;
z__9.r = z1 * grp1.r, z__9.i = z1 * grp1.i;
z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i;
z__6.r = z__7.r + gr2.r, z__6.i = z__7.i + gr2.i;
z__5.r = z__6.r + gr1.r, z__5.i = z__6.i + gr1.i;
z__4.r = ss * z__5.r, z__4.i = ss * z__5.i;
z__13.r = z2 * gr2.r, z__13.i = z2 * gr2.i;
z__14.r = z1 * gr1.r, z__14.i = z1 * gr1.i;
z__12.r = z__13.r - z__14.r, z__12.i = z__13.i - z__14.i;
z__11.r = cs * z__12.r, z__11.i = cs * z__12.i;
z__10.r = *xk * z__11.r, z__10.i = *xk * z__11.i;
z__3.r = z__4.r - z__10.r, z__3.i = z__4.i - z__10.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
ers->r = z__1.r, ers->i = z__1.i;
/*< >*/
z__2.r = -con->r, z__2.i = -con->i;
z__8.r = z2 * grp2.r, z__8.i = z2 * grp2.i;
z__9.r = z1 * grp1.r, z__9.i = z1 * grp1.i;
z__7.r = z__8.r - z__9.r, z__7.i = z__8.i - z__9.i;
z__6.r = z__7.r + gr2.r, z__6.i = z__7.i + gr2.i;
z__5.r = z__6.r - gr1.r, z__5.i = z__6.i - gr1.i;
z__4.r = cs * z__5.r, z__4.i = cs * z__5.i;
z__13.r = z2 * gr2.r, z__13.i = z2 * gr2.i;
z__14.r = z1 * gr1.r, z__14.i = z1 * gr1.i;
z__12.r = z__13.r + z__14.r, z__12.i = z__13.i + z__14.i;
z__11.r = ss * z__12.r, z__11.i = ss * z__12.i;
z__10.r = *xk * z__11.r, z__10.i = *xk * z__11.i;
z__3.r = z__4.r + z__10.r, z__3.i = z__4.i + z__10.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
erc->r = z__1.r, erc->i = z__1.i;
/*< ERK= CON*( GRK2- GRK1) >*/
z__2.r = grk2.r - grk1.r, z__2.i = grk2.i - grk1.i;
z__1.r = con->r * z__2.r - con->i * z__2.i, z__1.i = con->r * z__2.i +
con->i * z__2.r;
erk->r = z__1.r, erk->i = z__1.i;
/*< CALL INTX(- SHK, SHK, RHK, IJ, CINT, SINT) >*/
d__1 = -shk;
intx_(&d__1, &shk, &rhk, ij, &cint, &sint);
/*< BK= B* XK >*/
bk = b * *xk;
/*< BK2= BK* BK*.25 >*/
d__1 = bk * bk;
bk2 = d__1 * .25;
/*< >*/
z__2.r = -con->r, z__2.i = -con->i;
z__5.r = gzp2.r - gzp1.r, z__5.i = gzp2.i - gzp1.i;
d__2 = *xk * *xk;
d__1 = d__2 * (1. - bk2);
d__3 = -sint;
z__7.r = cint, z__7.i = d__3;
z__6.r = d__1 * z__7.r, z__6.i = d__1 * z__7.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__9.r = gzz2.r - gzz1.r, z__9.i = gzz2.i - gzz1.i;
z__8.r = bk2 * z__9.r, z__8.i = bk2 * z__9.i;
z__3.r = z__4.r - z__8.r, z__3.i = z__4.i - z__8.i;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
ezk->r = z__1.r, ezk->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* ekscx_ */
#undef con
#undef conx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< LOGICAL FUNCTION ENF( NUNIT) >*/
logical enf_(nunit)
integer *nunit;
{
/* System generated locals */
logical ret_val;
/* *** */
/* *********** THIS ROUTINE NOT USED ON VAX ************** */
/* IF (EOF,NUNIT) 1,2 */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< 1 ENF=.TRUE. >*/
/* L1: */
ret_val = TRUE_;
/*< RETURN >*/
return ret_val;
/*< 2 ENF=.FALSE. >*/
/* L2: */
ret_val = FALSE_;
/*< RETURN >*/
return ret_val;
/*< END >*/
} /* enf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */
/* *** */
/*< SUBROUTINE ERROR >*/
/* Subroutine */ int error_()
{
/* Format strings */
static char fmt_1[] = "(//,\002 **** ERROR **** \002,//,5x,a,//)";
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_indx(), s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
extern /* Subroutine */ int str0pc_();
static integer msglen, ind;
static char msg[80];
/* Fortran I/O blocks */
static cilist io___657 = { 0, 6, 0, fmt_1, 0 };
/*< IMPLICIT INTEGER (A-Z) >*/
/*< CHARACTER MSG*80 >*/
/* JCB CALL SYS$GETMSG(%VAL(RMSSTS),MSGLEN,MSG,,,) */
/* JCB CALL ERRSNS( FNUM, RMSSTS, RMSSTV, IUNIT, CNDVAL) */
/*< CALL STR0PC( MSG, MSG) >*/
str0pc_(msg, msg, 80L, 80L);
/*< IND= INDEX( MSG,',') >*/
ind = i_indx(msg, ",", 80L, 1L);
/*< PRINT1 , MSG( IND+2: MSGLEN) >*/
s_wsfe(&io___657);
i__1 = ind + 1;
do_fio(&c__1, msg + i__1, msglen - i__1);
e_wsfe();
/*< 1 FORMAT(//,' **** ERROR **** ',//,5X,A,//) >*/
/*< RETURN >*/
return 0;
/*< END >*/
} /* error_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE ETMNS( P1, P2, P3, P4, P5, P6, IPR, E) >*/
/* Subroutine */ int etmns_(p1, p2, p3, p4, p5, p6, ipr, e)
doublereal *p1, *p2, *p3, *p4, *p5, *p6;
integer *ipr;
doublecomplex *e;
{
/* Initialized data */
static doublereal tp = 6.283185308;
static doublereal reta = .002654420938;
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6;
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
/* Builtin functions */
double cos(), sin();
void z_sqrt(), z_div();
double sqrt();
/* Local variables */
static integer i;
static doublereal r;
extern /* Subroutine */ int qdsrc_();
static integer i1, i2, ii;
static doublecomplex er;
static doublereal ds;
static doublecomplex et, cx, cy, cz;
static integer is;
static doublereal rs, px, py, pz, qx, qy, qz, wx, wy, wz;
static doublecomplex tt1, tt2;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublereal arg, cph, cet;
static doublecomplex erh;
static doublereal cth, dsh;
static integer neq;
static doublecomplex ezh, rrh;
static doublereal sph, sth, set;
static integer npm;
static doublecomplex rrv;
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/* *** */
/* ETMNS FILLS THE ARRAY E WITH THE NEGATIVE OF THE ELECTRIC FIELD */
/* INCIDENT ON THE STRUCTURE. E IS THE RIGHT HAND SIDE OF THE MATRIX
*/
/* EQUATION. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< DIMENSION CAB(1), SAB(1), E( N2M) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
/*< >*/
/*< DATA TP/6.283185308D+0/, RETA/2.654420938D-3/ >*/
/* Parameter adjustments */
--e;
/* Function Body */
/*< NEQ= N+2* M >*/
neq = data_1.n + (data_1.m << 1);
/*< NQDS=0 >*/
vsorc_1.nqds = 0;
/* APPLIED FIELD OF VOLTAGE SOURCES FOR TRANSMITTING CASE */
/*< IF( IPR.GT.0.AND. IPR.NE.5) GOTO 5 >*/
if (*ipr > 0 && *ipr != 5) {
goto L5;
}
/*< DO 1 I=1, NEQ >*/
i__1 = neq;
for (i = 1; i <= i__1; ++i) {
/*< 1 E( I)=(0.,0.) >*/
/* L1: */
i__2 = i;
e[i__2].r = 0., e[i__2].i = 0.;
}
/*< IF( NSANT.EQ.0) GOTO 3 >*/
if (vsorc_1.nsant == 0) {
goto L3;
}
/*< DO 2 I=1, NSANT >*/
i__2 = vsorc_1.nsant;
for (i = 1; i <= i__2; ++i) {
/*< IS= ISANT( I) >*/
is = vsorc_1.isant[i - 1];
/*< 2 E( IS)=- VSANT( I)/( SI( IS)* WLAM) >*/
/* L2: */
i__1 = is;
i__3 = i - 1;
z__2.r = -vsorc_1.vsant[i__3].r, z__2.i = -vsorc_1.vsant[i__3].i;
d__1 = data_1.si[is - 1] * data_1.wlam;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
}
/*< 3 IF( NVQD.EQ.0) RETURN >*/
L3:
if (vsorc_1.nvqd == 0) {
return 0;
}
/*< DO 4 I=1, NVQD >*/
i__1 = vsorc_1.nvqd;
for (i = 1; i <= i__1; ++i) {
/*< IS= IVQD( I) >*/
is = vsorc_1.ivqd[i - 1];
/*< 4 CALL QDSRC( IS, VQD( I), E) >*/
/* L4: */
qdsrc_(&is, &vsorc_1.vqd[i - 1], &e[1]);
}
/*< RETURN >*/
return 0;
/* INCIDENT PLANE WAVE, LINEARLY POLARIZED. */
/*< 5 IF( IPR.GT.3) GOTO 19 >*/
L5:
if (*ipr > 3) {
goto L19;
}
/*< CTH= COS( P1) >*/
cth = cos(*p1);
/*< STH= SIN( P1) >*/
sth = sin(*p1);
/*< CPH= COS( P2) >*/
cph = cos(*p2);
/*< SPH= SIN( P2) >*/
sph = sin(*p2);
/*< CET= COS( P3) >*/
cet = cos(*p3);
/*< SET= SIN( P3) >*/
set = sin(*p3);
/*< PX= CTH* CPH* CET- SPH* SET >*/
d__1 = cth * cph;
px = d__1 * cet - sph * set;
/*< PY= CTH* SPH* CET+ CPH* SET >*/
d__1 = cth * sph;
py = d__1 * cet + cph * set;
/*< PZ=- STH* CET >*/
pz = -sth * cet;
/*< WX=- STH* CPH >*/
wx = -sth * cph;
/*< WY=- STH* SPH >*/
wy = -sth * sph;
/*< WZ=- CTH >*/
wz = -cth;
/*< QX= WY* PZ- WZ* PY >*/
qx = wy * pz - wz * py;
/*< QY= WZ* PX- WX* PZ >*/
qy = wz * px - wx * pz;
/*< QZ= WX* PY- WY* PX >*/
qz = wx * py - wy * px;
/*< IF( KSYMP.EQ.1) GOTO 7 >*/
if (gnd_1.ksymp == 1) {
goto L7;
}
/*< IF( IPERF.EQ.1) GOTO 6 >*/
if (gnd_1.iperf == 1) {
goto L6;
}
/*< RRV= SQRT(1.- ZRATI* ZRATI* STH* STH) >*/
z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * gnd_1.zrati.i,
z__5.i = gnd_1.zrati.r * gnd_1.zrati.i + gnd_1.zrati.i *
gnd_1.zrati.r;
z__4.r = sth * z__5.r, z__4.i = sth * z__5.i;
z__3.r = sth * z__4.r, z__3.i = sth * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRH= ZRATI* CTH >*/
z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRH=( RRH- RRV)/( RRH+ RRV) >*/
z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
z_div(&z__1, &z__2, &z__3);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRV= ZRATI* RRV >*/
z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i =
gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRV=-( CTH- RRV)/( CTH+ RRV) >*/
z__3.r = cth - rrv.r, z__3.i = -rrv.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__4.r = cth + rrv.r, z__4.i = rrv.i;
z_div(&z__1, &z__2, &z__4);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< GOTO 7 >*/
goto L7;
/*< 6 RRV=-(1.,0.) >*/
L6:
rrv.r = -1., rrv.i = 0.;
/*< RRH=-(1.,0.) >*/
rrh.r = -1., rrh.i = 0.;
/*< 7 IF( IPR.GT.1) GOTO 13 >*/
L7:
if (*ipr > 1) {
goto L13;
}
/*< IF( N.EQ.0) GOTO 10 >*/
if (data_1.n == 0) {
goto L10;
}
/*< DO 8 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
arg = -tp * (d__1 + wz * data_1.z[i - 1]);
/*< >*/
/* L8: */
i__3 = i;
d__2 = px * cab[i - 1] + py * sab[i - 1];
d__1 = -(d__2 + pz * angl_1.salp[i - 1]);
d__3 = cos(arg);
d__4 = sin(arg);
z__2.r = d__3, z__2.i = d__4;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
e[i__3].r = z__1.r, e[i__3].i = z__1.i;
}
/*< IF( KSYMP.EQ.1) GOTO 10 >*/
if (gnd_1.ksymp == 1) {
goto L10;
}
/*< TT1=( PY* CPH- PX* SPH)*( RRH- RRV) >*/
d__1 = py * cph - px * sph;
z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< CX= RRV* PX- TT1* SPH >*/
z__2.r = px * rrv.r, z__2.i = px * rrv.i;
z__3.r = sph * tt1.r, z__3.i = sph * tt1.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= RRV* PY+ TT1* CPH >*/
z__2.r = py * rrv.r, z__2.i = py * rrv.i;
z__3.r = cph * tt1.r, z__3.i = cph * tt1.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ=- RRV* PZ >*/
z__2.r = -rrv.r, z__2.i = -rrv.i;
z__1.r = pz * z__2.r, z__1.i = pz * z__2.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< DO 9 I=1, N >*/
i__3 = data_1.n;
for (i = 1; i <= i__3; ++i) {
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz *
data_1.z[i - 1]);
/*< >*/
/* L9: */
i__1 = i;
i__2 = i;
i__4 = i - 1;
z__5.r = cab[i__4] * cx.r, z__5.i = cab[i__4] * cx.i;
i__5 = i - 1;
z__6.r = sab[i__5] * cy.r, z__6.i = sab[i__5] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__6 = i - 1;
z__7.r = angl_1.salp[i__6] * cz.r, z__7.i = angl_1.salp[i__6] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
d__1 = cos(arg);
d__2 = sin(arg);
z__8.r = d__1, z__8.i = d__2;
z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i
+ z__3.i * z__8.r;
z__1.r = e[i__2].r - z__2.r, z__1.i = e[i__2].i - z__2.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
}
/*< 10 IF( M.EQ.0) RETURN >*/
L10:
if (data_1.m == 0) {
return 0;
}
/*< I= LD+1 >*/
i = data_1.ld + 1;
/*< I1= N-1 >*/
i1 = data_1.n - 1;
/*< DO 11 IS=1, M >*/
i__1 = data_1.m;
for (is = 1; is <= i__1; ++is) {
/*< I= I-1 >*/
--i;
/*< I1= I1+2 >*/
i1 += 2;
/*< I2= I1+1 >*/
i2 = i1 + 1;
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
arg = -tp * (d__1 + wz * data_1.z[i - 1]);
/*< TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__3.r = d__1, z__3.i = d__2;
i__2 = i - 1;
z__2.r = angl_1.salp[i__2] * z__3.r, z__2.i = angl_1.salp[i__2] *
z__3.i;
z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< E( I2)=( QX* T1X( I)+ QY* T1Y( I)+ QZ* T1Z( I))* TT1 >*/
i__2 = i2;
d__2 = qx * t1x[i - 1] + qy * t1y[i - 1];
d__1 = d__2 + qz * t1z[i - 1];
z__1.r = d__1 * tt1.r, z__1.i = d__1 * tt1.i;
e[i__2].r = z__1.r, e[i__2].i = z__1.i;
/*< 11 E( I1)=( QX* T2X( I)+ QY* T2Y( I)+ QZ* T2Z( I))* TT1 >*/
/* L11: */
i__2 = i1;
d__2 = qx * t2x[i - 1] + qy * t2y[i - 1];
d__1 = d__2 + qz * t2z[i - 1];
z__1.r = d__1 * tt1.r, z__1.i = d__1 * tt1.i;
e[i__2].r = z__1.r, e[i__2].i = z__1.i;
}
/*< IF( KSYMP.EQ.1) RETURN >*/
if (gnd_1.ksymp == 1) {
return 0;
}
/*< TT1=( QY* CPH- QX* SPH)*( RRV- RRH) >*/
d__1 = qy * cph - qx * sph;
z__2.r = rrv.r - rrh.r, z__2.i = rrv.i - rrh.i;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< CX=-( RRH* QX- TT1* SPH) >*/
z__3.r = qx * rrh.r, z__3.i = qx * rrh.i;
z__4.r = sph * tt1.r, z__4.i = sph * tt1.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY=-( RRH* QY+ TT1* CPH) >*/
z__3.r = qy * rrh.r, z__3.i = qy * rrh.i;
z__4.r = cph * tt1.r, z__4.i = cph * tt1.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= RRH* QZ >*/
z__1.r = qz * rrh.r, z__1.i = qz * rrh.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< I= LD+1 >*/
i = data_1.ld + 1;
/*< I1= N-1 >*/
i1 = data_1.n - 1;
/*< DO 12 IS=1, M >*/
i__2 = data_1.m;
for (is = 1; is <= i__2; ++is) {
/*< I= I-1 >*/
--i;
/*< I1= I1+2 >*/
i1 += 2;
/*< I2= I1+1 >*/
i2 = i1 + 1;
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz *
data_1.z[i - 1]);
/*< TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__3.r = d__1, z__3.i = d__2;
i__1 = i - 1;
z__2.r = angl_1.salp[i__1] * z__3.r, z__2.i = angl_1.salp[i__1] *
z__3.i;
z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1 >*/
i__1 = i2;
i__4 = i2;
i__5 = i - 1;
z__5.r = t1x[i__5] * cx.r, z__5.i = t1x[i__5] * cx.i;
i__6 = i - 1;
z__6.r = t1y[i__6] * cy.r, z__6.i = t1y[i__6] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__3 = i - 1;
z__7.r = t1z[i__3] * cz.r, z__7.i = t1z[i__3] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i +
z__3.i * tt1.r;
z__1.r = e[i__4].r + z__2.r, z__1.i = e[i__4].i + z__2.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
/*< 12 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1 >*/
/* L12: */
i__1 = i1;
i__4 = i1;
i__5 = i - 1;
z__5.r = t2x[i__5] * cx.r, z__5.i = t2x[i__5] * cx.i;
i__6 = i - 1;
z__6.r = t2y[i__6] * cy.r, z__6.i = t2y[i__6] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__3 = i - 1;
z__7.r = t2z[i__3] * cz.r, z__7.i = t2z[i__3] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i +
z__3.i * tt1.r;
z__1.r = e[i__4].r + z__2.r, z__1.i = e[i__4].i + z__2.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
}
/* INCIDENT PLANE WAVE, ELLIPTIC POLARIZATION. */
/*< RETURN >*/
return 0;
/*< 13 TT1=-(0.,1.)* P6 >*/
L13:
z__1.r = *p6 * 0., z__1.i = *p6 * -1.;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< IF( IPR.EQ.3) TT1=- TT1 >*/
if (*ipr == 3) {
z__1.r = -tt1.r, z__1.i = -tt1.i;
tt1.r = z__1.r, tt1.i = z__1.i;
}
/*< IF( N.EQ.0) GOTO 16 >*/
if (data_1.n == 0) {
goto L16;
}
/*< CX= PX+ TT1* QX >*/
z__2.r = qx * tt1.r, z__2.i = qx * tt1.i;
z__1.r = px + z__2.r, z__1.i = z__2.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= PY+ TT1* QY >*/
z__2.r = qy * tt1.r, z__2.i = qy * tt1.i;
z__1.r = py + z__2.r, z__1.i = z__2.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= PZ+ TT1* QZ >*/
z__2.r = qz * tt1.r, z__2.i = qz * tt1.i;
z__1.r = pz + z__2.r, z__1.i = z__2.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< DO 14 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
arg = -tp * (d__1 + wz * data_1.z[i - 1]);
/*< >*/
/* L14: */
i__4 = i;
i__5 = i - 1;
z__5.r = cab[i__5] * cx.r, z__5.i = cab[i__5] * cx.i;
i__6 = i - 1;
z__6.r = sab[i__6] * cy.r, z__6.i = sab[i__6] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__3 = i - 1;
z__7.r = angl_1.salp[i__3] * cz.r, z__7.i = angl_1.salp[i__3] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
d__1 = cos(arg);
d__2 = sin(arg);
z__8.r = d__1, z__8.i = d__2;
z__1.r = z__2.r * z__8.r - z__2.i * z__8.i, z__1.i = z__2.r * z__8.i
+ z__2.i * z__8.r;
e[i__4].r = z__1.r, e[i__4].i = z__1.i;
}
/*< IF( KSYMP.EQ.1) GOTO 16 >*/
if (gnd_1.ksymp == 1) {
goto L16;
}
/*< TT2=( CY* CPH- CX* SPH)*( RRH- RRV) >*/
z__3.r = cph * cy.r, z__3.i = cph * cy.i;
z__4.r = sph * cx.r, z__4.i = sph * cx.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i +
z__2.i * z__5.r;
tt2.r = z__1.r, tt2.i = z__1.i;
/*< CX= RRV* CX- TT2* SPH >*/
z__2.r = rrv.r * cx.r - rrv.i * cx.i, z__2.i = rrv.r * cx.i + rrv.i *
cx.r;
z__3.r = sph * tt2.r, z__3.i = sph * tt2.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= RRV* CY+ TT2* CPH >*/
z__2.r = rrv.r * cy.r - rrv.i * cy.i, z__2.i = rrv.r * cy.i + rrv.i *
cy.r;
z__3.r = cph * tt2.r, z__3.i = cph * tt2.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ=- RRV* CZ >*/
z__2.r = -rrv.r, z__2.i = -rrv.i;
z__1.r = z__2.r * cz.r - z__2.i * cz.i, z__1.i = z__2.r * cz.i + z__2.i *
cz.r;
cz.r = z__1.r, cz.i = z__1.i;
/*< DO 15 I=1, N >*/
i__4 = data_1.n;
for (i = 1; i <= i__4; ++i) {
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz *
data_1.z[i - 1]);
/*< >*/
/* L15: */
i__5 = i;
i__6 = i;
i__3 = i - 1;
z__5.r = cab[i__3] * cx.r, z__5.i = cab[i__3] * cx.i;
i__1 = i - 1;
z__6.r = sab[i__1] * cy.r, z__6.i = sab[i__1] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__2 = i - 1;
z__7.r = angl_1.salp[i__2] * cz.r, z__7.i = angl_1.salp[i__2] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
d__1 = cos(arg);
d__2 = sin(arg);
z__8.r = d__1, z__8.i = d__2;
z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i
+ z__3.i * z__8.r;
z__1.r = e[i__6].r - z__2.r, z__1.i = e[i__6].i - z__2.i;
e[i__5].r = z__1.r, e[i__5].i = z__1.i;
}
/*< 16 IF( M.EQ.0) RETURN >*/
L16:
if (data_1.m == 0) {
return 0;
}
/*< CX= QX- TT1* PX >*/
z__2.r = px * tt1.r, z__2.i = px * tt1.i;
z__1.r = qx - z__2.r, z__1.i = -z__2.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= QY- TT1* PY >*/
z__2.r = py * tt1.r, z__2.i = py * tt1.i;
z__1.r = qy - z__2.r, z__1.i = -z__2.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= QZ- TT1* PZ >*/
z__2.r = pz * tt1.r, z__2.i = pz * tt1.i;
z__1.r = qz - z__2.r, z__1.i = -z__2.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< I= LD+1 >*/
i = data_1.ld + 1;
/*< I1= N-1 >*/
i1 = data_1.n - 1;
/*< DO 17 IS=1, M >*/
i__5 = data_1.m;
for (is = 1; is <= i__5; ++is) {
/*< I= I-1 >*/
--i;
/*< I1= I1+2 >*/
i1 += 2;
/*< I2= I1+1 >*/
i2 = i1 + 1;
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)+ WZ* Z( I)) >*/
d__1 = wx * data_1.x[i - 1] + wy * data_1.y[i - 1];
arg = -tp * (d__1 + wz * data_1.z[i - 1]);
/*< TT2= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__3.r = d__1, z__3.i = d__2;
i__6 = i - 1;
z__2.r = angl_1.salp[i__6] * z__3.r, z__2.i = angl_1.salp[i__6] *
z__3.i;
z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
tt2.r = z__1.r, tt2.i = z__1.i;
/*< E( I2)=( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT2 >*/
i__6 = i2;
i__3 = i - 1;
z__4.r = t1x[i__3] * cx.r, z__4.i = t1x[i__3] * cx.i;
i__1 = i - 1;
z__5.r = t1y[i__1] * cy.r, z__5.i = t1y[i__1] * cy.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
i__2 = i - 1;
z__6.r = t1z[i__2] * cz.r, z__6.i = t1z[i__2] * cz.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = z__2.r * tt2.r - z__2.i * tt2.i, z__1.i = z__2.r * tt2.i +
z__2.i * tt2.r;
e[i__6].r = z__1.r, e[i__6].i = z__1.i;
/*< 17 E( I1)=( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT2 >*/
/* L17: */
i__6 = i1;
i__3 = i - 1;
z__4.r = t2x[i__3] * cx.r, z__4.i = t2x[i__3] * cx.i;
i__1 = i - 1;
z__5.r = t2y[i__1] * cy.r, z__5.i = t2y[i__1] * cy.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
i__2 = i - 1;
z__6.r = t2z[i__2] * cz.r, z__6.i = t2z[i__2] * cz.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = z__2.r * tt2.r - z__2.i * tt2.i, z__1.i = z__2.r * tt2.i +
z__2.i * tt2.r;
e[i__6].r = z__1.r, e[i__6].i = z__1.i;
}
/*< IF( KSYMP.EQ.1) RETURN >*/
if (gnd_1.ksymp == 1) {
return 0;
}
/*< TT1=( CY* CPH- CX* SPH)*( RRV- RRH) >*/
z__3.r = cph * cy.r, z__3.i = cph * cy.i;
z__4.r = sph * cx.r, z__4.i = sph * cx.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i +
z__2.i * z__5.r;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< CX=-( RRH* CX- TT1* SPH) >*/
z__3.r = rrh.r * cx.r - rrh.i * cx.i, z__3.i = rrh.r * cx.i + rrh.i *
cx.r;
z__4.r = sph * tt1.r, z__4.i = sph * tt1.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY=-( RRH* CY+ TT1* CPH) >*/
z__3.r = rrh.r * cy.r - rrh.i * cy.i, z__3.i = rrh.r * cy.i + rrh.i *
cy.r;
z__4.r = cph * tt1.r, z__4.i = cph * tt1.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= RRH* CZ >*/
z__1.r = rrh.r * cz.r - rrh.i * cz.i, z__1.i = rrh.r * cz.i + rrh.i *
cz.r;
cz.r = z__1.r, cz.i = z__1.i;
/*< I= LD+1 >*/
i = data_1.ld + 1;
/*< I1= N-1 >*/
i1 = data_1.n - 1;
/*< DO 18 IS=1, M >*/
i__6 = data_1.m;
for (is = 1; is <= i__6; ++is) {
/*< I= I-1 >*/
--i;
/*< I1= I1+2 >*/
i1 += 2;
/*< I2= I1+1 >*/
i2 = i1 + 1;
/*< ARG=- TP*( WX* X( I)+ WY* Y( I)- WZ* Z( I)) >*/
arg = -tp * (wx * data_1.x[i - 1] + wy * data_1.y[i - 1] - wz *
data_1.z[i - 1]);
/*< TT1= CMPLX( COS( ARG), SIN( ARG))* SALP( I)* RETA >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__3.r = d__1, z__3.i = d__2;
i__3 = i - 1;
z__2.r = angl_1.salp[i__3] * z__3.r, z__2.i = angl_1.salp[i__3] *
z__3.i;
z__1.r = reta * z__2.r, z__1.i = reta * z__2.i;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< E( I2)= E( I2)+( CX* T1X( I)+ CY* T1Y( I)+ CZ* T1Z( I))* TT1 >*/
i__3 = i2;
i__1 = i2;
i__2 = i - 1;
z__5.r = t1x[i__2] * cx.r, z__5.i = t1x[i__2] * cx.i;
i__5 = i - 1;
z__6.r = t1y[i__5] * cy.r, z__6.i = t1y[i__5] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__4 = i - 1;
z__7.r = t1z[i__4] * cz.r, z__7.i = t1z[i__4] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i +
z__3.i * tt1.r;
z__1.r = e[i__1].r + z__2.r, z__1.i = e[i__1].i + z__2.i;
e[i__3].r = z__1.r, e[i__3].i = z__1.i;
/*< 18 E( I1)= E( I1)+( CX* T2X( I)+ CY* T2Y( I)+ CZ* T2Z( I))* TT1 >*/
/* L18: */
i__3 = i1;
i__1 = i1;
i__2 = i - 1;
z__5.r = t2x[i__2] * cx.r, z__5.i = t2x[i__2] * cx.i;
i__5 = i - 1;
z__6.r = t2y[i__5] * cy.r, z__6.i = t2y[i__5] * cy.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__4 = i - 1;
z__7.r = t2z[i__4] * cz.r, z__7.i = t2z[i__4] * cz.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = z__3.r * tt1.r - z__3.i * tt1.i, z__2.i = z__3.r * tt1.i +
z__3.i * tt1.r;
z__1.r = e[i__1].r + z__2.r, z__1.i = e[i__1].i + z__2.i;
e[i__3].r = z__1.r, e[i__3].i = z__1.i;
}
/* INCIDENT FIELD OF AN ELEMENTARY CURRENT SOURCE. */
/*< RETURN >*/
return 0;
/*< 19 WZ= COS( P4) >*/
L19:
wz = cos(*p4);
/*< WX= WZ* COS( P5) >*/
wx = wz * cos(*p5);
/*< WY= WZ* SIN( P5) >*/
wy = wz * sin(*p5);
/*< WZ= SIN( P4) >*/
wz = sin(*p4);
/*< DS= P6*59.958 >*/
ds = *p6 * 59.958;
/*< DSH= P6/(2.* TP) >*/
dsh = *p6 / (tp * 2.);
/*< NPM= N+ M >*/
npm = data_1.n + data_1.m;
/*< IS= LD+1 >*/
is = data_1.ld + 1;
/*< I1= N-1 >*/
i1 = data_1.n - 1;
/*< DO 24 I=1, NPM >*/
i__3 = npm;
for (i = 1; i <= i__3; ++i) {
/*< II= I >*/
ii = i;
/*< IF( I.LE. N) GOTO 20 >*/
if (i <= data_1.n) {
goto L20;
}
/*< IS= IS-1 >*/
--is;
/*< II= IS >*/
ii = is;
/*< I1= I1+2 >*/
i1 += 2;
/*< I2= I1+1 >*/
i2 = i1 + 1;
/*< 20 PX= X( II)- P1 >*/
L20:
px = data_1.x[ii - 1] - *p1;
/*< PY= Y( II)- P2 >*/
py = data_1.y[ii - 1] - *p2;
/*< PZ= Z( II)- P3 >*/
pz = data_1.z[ii - 1] - *p3;
/*< RS= PX* PX+ PY* PY+ PZ* PZ >*/
d__1 = px * px + py * py;
rs = d__1 + pz * pz;
/*< IF( RS.LT.1.D-30) GOTO 24 >*/
if (rs < 1e-30) {
goto L24;
}
/*< R= SQRT( RS) >*/
r = sqrt(rs);
/*< PX= PX/ R >*/
px /= r;
/*< PY= PY/ R >*/
py /= r;
/*< PZ= PZ/ R >*/
pz /= r;
/*< CTH= PX* WX+ PY* WY+ PZ* WZ >*/
d__1 = px * wx + py * wy;
cth = d__1 + pz * wz;
/*< STH= SQRT(1.- CTH* CTH) >*/
sth = sqrt(1. - cth * cth);
/*< QX= PX- WX* CTH >*/
qx = px - wx * cth;
/*< QY= PY- WY* CTH >*/
qy = py - wy * cth;
/*< QZ= PZ- WZ* CTH >*/
qz = pz - wz * cth;
/*< ARG= SQRT( QX* QX+ QY* QY+ QZ* QZ) >*/
d__1 = qx * qx + qy * qy;
arg = sqrt(d__1 + qz * qz);
/*< IF( ARG.LT.1.D-30) GOTO 21 >*/
if (arg < 1e-30) {
goto L21;
}
/*< QX= QX/ ARG >*/
qx /= arg;
/*< QY= QY/ ARG >*/
qy /= arg;
/*< QZ= QZ/ ARG >*/
qz /= arg;
/*< GOTO 22 >*/
goto L22;
/*< 21 QX=1. >*/
L21:
qx = 1.;
/*< QY=0. >*/
qy = 0.;
/*< QZ=0. >*/
qz = 0.;
/*< 22 ARG=- TP* R >*/
L22:
arg = -tp * r;
/*< TT1= CMPLX( COS( ARG), SIN( ARG)) >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__1.r = d__1, z__1.i = d__2;
tt1.r = z__1.r, tt1.i = z__1.i;
/*< IF( I.GT. N) GOTO 23 >*/
if (i > data_1.n) {
goto L23;
}
/*< TT2= CMPLX(1.D+0,-1.D+0/( R* TP))/ RS >*/
d__1 = -1. / (r * tp);
z__2.r = 1., z__2.i = d__1;
z__1.r = z__2.r / rs, z__1.i = z__2.i / rs;
tt2.r = z__1.r, tt2.i = z__1.i;
/*< ER= DS* TT1* TT2* CTH >*/
z__3.r = ds * tt1.r, z__3.i = ds * tt1.i;
z__2.r = z__3.r * tt2.r - z__3.i * tt2.i, z__2.i = z__3.r * tt2.i +
z__3.i * tt2.r;
z__1.r = cth * z__2.r, z__1.i = cth * z__2.i;
er.r = z__1.r, er.i = z__1.i;
/*< ET=.5* DS* TT1*((0.,1.)* TP/ R+ TT2)* STH >*/
d__1 = ds * .5;
z__3.r = d__1 * tt1.r, z__3.i = d__1 * tt1.i;
z__6.r = tp * 0., z__6.i = tp * 1.;
z__5.r = z__6.r / r, z__5.i = z__6.i / r;
z__4.r = z__5.r + tt2.r, z__4.i = z__5.i + tt2.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
z__1.r = sth * z__2.r, z__1.i = sth * z__2.i;
et.r = z__1.r, et.i = z__1.i;
/*< EZH= ER* CTH- ET* STH >*/
z__2.r = cth * er.r, z__2.i = cth * er.i;
z__3.r = sth * et.r, z__3.i = sth * et.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ezh.r = z__1.r, ezh.i = z__1.i;
/*< ERH= ER* STH+ ET* CTH >*/
z__2.r = sth * er.r, z__2.i = sth * er.i;
z__3.r = cth * et.r, z__3.i = cth * et.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
erh.r = z__1.r, erh.i = z__1.i;
/*< CX= EZH* WX+ ERH* QX >*/
z__2.r = wx * ezh.r, z__2.i = wx * ezh.i;
z__3.r = qx * erh.r, z__3.i = qx * erh.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= EZH* WY+ ERH* QY >*/
z__2.r = wy * ezh.r, z__2.i = wy * ezh.i;
z__3.r = qy * erh.r, z__3.i = qy * erh.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= EZH* WZ+ ERH* QZ >*/
z__2.r = wz * ezh.r, z__2.i = wz * ezh.i;
z__3.r = qz * erh.r, z__3.i = qz * erh.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< E( I)=-( CX* CAB( I)+ CY* SAB( I)+ CZ* SALP( I)) >*/
i__1 = i;
i__2 = i - 1;
z__4.r = cab[i__2] * cx.r, z__4.i = cab[i__2] * cx.i;
i__5 = i - 1;
z__5.r = sab[i__5] * cy.r, z__5.i = sab[i__5] * cy.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
i__4 = i - 1;
z__6.r = angl_1.salp[i__4] * cz.r, z__6.i = angl_1.salp[i__4] * cz.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = -z__2.r, z__1.i = -z__2.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
/*< GOTO 24 >*/
goto L24;
/*< 23 PX= WY* QZ- WZ* QY >*/
L23:
px = wy * qz - wz * qy;
/*< PY= WZ* QX- WX* QZ >*/
py = wz * qx - wx * qz;
/*< PZ= WX* QY- WY* QX >*/
pz = wx * qy - wy * qx;
/*< TT2= DSH* TT1* CMPLX(1./ R, TP)/ R* STH* SALP( II) >*/
z__5.r = dsh * tt1.r, z__5.i = dsh * tt1.i;
d__1 = 1. / r;
z__6.r = d__1, z__6.i = tp;
z__4.r = z__5.r * z__6.r - z__5.i * z__6.i, z__4.i = z__5.r * z__6.i
+ z__5.i * z__6.r;
z__3.r = z__4.r / r, z__3.i = z__4.i / r;
z__2.r = sth * z__3.r, z__2.i = sth * z__3.i;
i__1 = ii - 1;
z__1.r = angl_1.salp[i__1] * z__2.r, z__1.i = angl_1.salp[i__1] *
z__2.i;
tt2.r = z__1.r, tt2.i = z__1.i;
/*< CX= TT2* PX >*/
z__1.r = px * tt2.r, z__1.i = px * tt2.i;
cx.r = z__1.r, cx.i = z__1.i;
/*< CY= TT2* PY >*/
z__1.r = py * tt2.r, z__1.i = py * tt2.i;
cy.r = z__1.r, cy.i = z__1.i;
/*< CZ= TT2* PZ >*/
z__1.r = pz * tt2.r, z__1.i = pz * tt2.i;
cz.r = z__1.r, cz.i = z__1.i;
/*< E( I2)= CX* T1X( II)+ CY* T1Y( II)+ CZ* T1Z( II) >*/
i__1 = i2;
i__2 = ii - 1;
z__3.r = t1x[i__2] * cx.r, z__3.i = t1x[i__2] * cx.i;
i__5 = ii - 1;
z__4.r = t1y[i__5] * cy.r, z__4.i = t1y[i__5] * cy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = ii - 1;
z__5.r = t1z[i__4] * cz.r, z__5.i = t1z[i__4] * cz.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
/*< E( I1)= CX* T2X( II)+ CY* T2Y( II)+ CZ* T2Z( II) >*/
i__1 = i1;
i__2 = ii - 1;
z__3.r = t2x[i__2] * cx.r, z__3.i = t2x[i__2] * cx.i;
i__5 = ii - 1;
z__4.r = t2y[i__5] * cy.r, z__4.i = t2y[i__5] * cy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = ii - 1;
z__5.r = t2z[i__4] * cz.r, z__5.i = t2z[i__4] * cz.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
e[i__1].r = z__1.r, e[i__1].i = z__1.i;
/*< 24 CONTINUE >*/
L24:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* etmns_ */
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int facgf_(a, b, c, d, bx, ip, ix, np, n1, mp, m1, n1c, n2c)
doublecomplex *a, *b, *c, *d, *bx;
integer *ip, *ix, *np, *n1, *mp, *m1, *n1c, *n2c;
{
/* System generated locals */
integer b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, bx_dim1,
bx_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7;
doublecomplex z__1, z__2;
alist al__1;
/* Builtin functions */
integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue();
/* Local variables */
static integer ibfl, i, j, k;
extern /* Subroutine */ int facio_(), reblk_(), factr_();
static integer icass, nlsys, npsys, ib, ic, ii;
extern /* Subroutine */ int lunscr_();
static integer nblsys;
extern /* Subroutine */ int solves_();
static integer nic, npb, npc;
static doublecomplex sum;
static integer n1cp;
/* Fortran I/O blocks */
static cilist io___710 = { 0, 0, 0, 0, 0 };
static cilist io___713 = { 0, 14, 0, 0, 0 };
static cilist io___716 = { 0, 15, 0, 0, 0 };
static cilist io___717 = { 0, 12, 0, 0, 0 };
static cilist io___719 = { 0, 14, 0, 0, 0 };
static cilist io___723 = { 0, 11, 0, 0, 0 };
static cilist io___725 = { 0, 11, 0, 0, 0 };
static cilist io___726 = { 0, 11, 0, 0, 0 };
/* *** */
/* FACGF COMPUTES AND FACTORS D-C(INV(A)B). */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMPLEX A, B, C, D, BX, SUM >*/
/*< >*/
/*< >*/
/*< IF( N2C.EQ.0) RETURN >*/
/* Parameter adjustments */
--ix;
--ip;
bx_dim1 = *n1c;
bx_offset = bx_dim1 + 1;
bx -= bx_offset;
d_dim1 = *n2c;
d_offset = d_dim1 + 1;
d -= d_offset;
c_dim1 = *n1c;
c_offset = c_dim1 + 1;
c -= c_offset;
b_dim1 = *n1c;
b_offset = b_dim1 + 1;
b -= b_offset;
--a;
/* Function Body */
if (*n2c == 0) {
return 0;
}
/*< IBFL=14 >*/
ibfl = 14;
/* CONVERT B FROM BLOCKS OF ROWS ON T14 TO BLOCKS OF COL. ON T16 */
/*< IF( ICASX.LT.3) GOTO 1 >*/
if (matpar_1.icasx < 3) {
goto L1;
}
/*< CALL REBLK( B, C, N1C, NPBX, N2C) >*/
reblk_(&b[b_offset], &c[c_offset], n1c, &matpar_1.npbx, n2c);
/*< IBFL=16 >*/
ibfl = 16;
/*< 1 NPB= NPBL >*/
L1:
npb = matpar_1.npbl;
/* COMPUTE INV(A)B AND WRITE ON TAPE14 */
/*< IF( ICASX.EQ.2) REWIND 14 >*/
if (matpar_1.icasx == 2) {
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
}
/*< DO 2 IB=1, NBBL >*/
i__1 = matpar_1.nbbl;
for (ib = 1; ib <= i__1; ++ib) {
/*< IF( IB.EQ. NBBL) NPB= NLBL >*/
if (ib == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< IF( ICASX.GT.1) READ( IBFL) (( BX( I, J), I=1, N1C), J=1, NPB) >*/
if (matpar_1.icasx > 1) {
io___710.ciunit = ibfl;
s_rsue(&io___710);
i__2 = npb;
for (j = 1; j <= i__2; ++j) {
i__3 = *n1c;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
sizeof(doublereal));
}
}
e_rsue();
}
/*< CALL SOLVES( A, IP, BX, N1C, NPB, NP, N1, MP, M1,13,13) >*/
solves_(&a[1], &ip[1], &bx[bx_offset], n1c, &npb, np, n1, mp, m1, &
c__13, &c__13);
/*< IF( ICASX.EQ.2) REWIND 14 >*/
if (matpar_1.icasx == 2) {
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
}
/*< IF( ICASX.GT.1) WRITE( 14) (( BX( I, J), I=1, N1C), J=1, NPB) >*/
if (matpar_1.icasx > 1) {
s_wsue(&io___713);
i__3 = npb;
for (j = 1; j <= i__3; ++j) {
i__2 = *n1c;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
sizeof(doublereal));
}
}
e_wsue();
}
/*< 2 CONTINUE >*/
/* L2: */
}
/*< IF( ICASX.EQ.1) GOTO 3 >*/
if (matpar_1.icasx == 1) {
goto L3;
}
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< REWIND 12 >*/
al__1.aerr = 0;
al__1.aunit = 12;
f_rew(&al__1);
/*< REWIND 15 >*/
al__1.aerr = 0;
al__1.aunit = 15;
f_rew(&al__1);
/*< REWIND IBFL >*/
al__1.aerr = 0;
al__1.aunit = ibfl;
f_rew(&al__1);
/* COMPUTE D-C(INV(A)B) AND WRITE ON TAPE11 */
/*< 3 NPC= NPBL >*/
L3:
npc = matpar_1.npbl;
/*< DO 8 IC=1, NBBL >*/
i__1 = matpar_1.nbbl;
for (ic = 1; ic <= i__1; ++ic) {
/*< IF( IC.EQ. NBBL) NPC= NLBL >*/
if (ic == matpar_1.nbbl) {
npc = matpar_1.nlbl;
}
/*< IF( ICASX.EQ.1) GOTO 4 >*/
if (matpar_1.icasx == 1) {
goto L4;
}
/*< READ( 15) (( C( I, J), I=1, N1C), J=1, NPC) >*/
s_rsue(&io___716);
i__2 = npc;
for (j = 1; j <= i__2; ++j) {
i__3 = *n1c;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__2, (char *)&c[i + j * c_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_rsue();
/*< READ( 12) (( D( I, J), I=1, N2C), J=1, NPC) >*/
s_rsue(&io___717);
i__3 = npc;
for (j = 1; j <= i__3; ++j) {
i__2 = *n2c;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&d[i + j * d_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_rsue();
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< 4 NPB= NPBL >*/
L4:
npb = matpar_1.npbl;
/*< NIC=0 >*/
nic = 0;
/*< DO 7 IB=1, NBBL >*/
i__2 = matpar_1.nbbl;
for (ib = 1; ib <= i__2; ++ib) {
/*< IF( IB.EQ. NBBL) NPB= NLBL >*/
if (ib == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB) >*/
if (matpar_1.icasx > 1) {
s_rsue(&io___719);
i__3 = npb;
for (j = 1; j <= i__3; ++j) {
i__4 = *n1c;
for (i = 1; i <= i__4; ++i) {
do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)
sizeof(doublereal));
}
}
e_rsue();
}
/*< DO 6 I=1, NPB >*/
i__4 = npb;
for (i = 1; i <= i__4; ++i) {
/*< II= I+ NIC >*/
ii = i + nic;
/*< DO 6 J=1, NPC >*/
i__3 = npc;
for (j = 1; j <= i__3; ++j) {
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< DO 5 K=1, N1C >*/
i__5 = *n1c;
for (k = 1; k <= i__5; ++k) {
/*< 5 SUM= SUM+ B( K, I)* C( K, J) >*/
/* L5: */
i__6 = k + i * b_dim1;
i__7 = k + j * c_dim1;
z__2.r = b[i__6].r * c[i__7].r - b[i__6].i * c[i__7]
.i, z__2.i = b[i__6].r * c[i__7].i + b[i__6]
.i * c[i__7].r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< 6 D( II, J)= D( II, J)- SUM >*/
/* L6: */
i__6 = ii + j * d_dim1;
i__7 = ii + j * d_dim1;
z__1.r = d[i__7].r - sum.r, z__1.i = d[i__7].i - sum.i;
d[i__6].r = z__1.r, d[i__6].i = z__1.i;
}
}
/*< 7 NIC= NIC+ NPBL >*/
/* L7: */
nic += matpar_1.npbl;
}
/*< IF( ICASX.GT.1) WRITE( 11) (( D( I, J), I=1, N2C), J=1, NPBL) >*/
if (matpar_1.icasx > 1) {
s_wsue(&io___723);
i__2 = matpar_1.npbl;
for (j = 1; j <= i__2; ++j) {
i__6 = *n2c;
for (i = 1; i <= i__6; ++i) {
do_uio(&c__2, (char *)&d[i + j * d_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
}
/*< 8 CONTINUE >*/
/* L8: */
}
/*< IF( ICASX.EQ.1) GOTO 9 >*/
if (matpar_1.icasx == 1) {
goto L9;
}
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< REWIND 12 >*/
al__1.aerr = 0;
al__1.aunit = 12;
f_rew(&al__1);
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< REWIND 15 >*/
al__1.aerr = 0;
al__1.aunit = 15;
f_rew(&al__1);
/* FACTOR D-C(INV(A)B) */
/*< 9 N1CP= N1C+1 >*/
L9:
n1cp = *n1c + 1;
/*< IF( ICASX.GT.1) GOTO 10 >*/
if (matpar_1.icasx > 1) {
goto L10;
}
/*< CALL FACTR( N2C, D, IP( N1CP), N2C) >*/
factr_(n2c, &d[d_offset], &ip[n1cp], n2c);
/*< GOTO 13 >*/
goto L13;
/*< 10 IF( ICASX.EQ.4) GOTO 12 >*/
L10:
if (matpar_1.icasx == 4) {
goto L12;
}
/*< NPB= NPBL >*/
npb = matpar_1.npbl;
/*< IC=0 >*/
ic = 0;
/*< DO 11 IB=1, NBBL >*/
i__1 = matpar_1.nbbl;
for (ib = 1; ib <= i__1; ++ib) {
/*< IF( IB.EQ. NBBL) NPB= NLBL >*/
if (ib == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< II= IC+1 >*/
ii = ic + 1;
/*< IC= IC+ N2C* NPB >*/
ic += *n2c * npb;
/*< 11 READ( 11) ( B( I,1), I= II, IC) >*/
/* L11: */
s_rsue(&io___725);
i__6 = ic;
for (i = ii; i <= i__6; ++i) {
do_uio(&c__2, (char *)&b[i + b_dim1], (ftnlen)sizeof(doublereal));
}
e_rsue();
}
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< CALL FACTR( N2C, B, IP( N1CP), N2C) >*/
factr_(n2c, &b[b_offset], &ip[n1cp], n2c);
/*< NIC= N2C* N2C >*/
nic = *n2c * *n2c;
/*< WRITE( 11) ( B( I,1), I=1, NIC) >*/
s_wsue(&io___726);
i__6 = nic;
for (i = 1; i <= i__6; ++i) {
do_uio(&c__2, (char *)&b[i + b_dim1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< GOTO 13 >*/
goto L13;
/*< 12 NBLSYS= NBLSYM >*/
L12:
nblsys = matpar_1.nblsym;
/*< NPSYS= NPSYM >*/
npsys = matpar_1.npsym;
/*< NLSYS= NLSYM >*/
nlsys = matpar_1.nlsym;
/*< ICASS= ICASE >*/
icass = matpar_1.icase;
/*< NBLSYM= NBBL >*/
matpar_1.nblsym = matpar_1.nbbl;
/*< NPSYM= NPBL >*/
matpar_1.npsym = matpar_1.npbl;
/*< NLSYM= NLBL >*/
matpar_1.nlsym = matpar_1.nlbl;
/*< ICASE=3 >*/
matpar_1.icase = 3;
/*< CALL FACIO( B, N2C,1, IX( N1CP),11,12,16,11) >*/
facio_(&b[b_offset], n2c, &c__1, &ix[n1cp], &c__11, &c__12, &c__16, &
c__11);
/*< CALL LUNSCR( B, N2C,1, IP( N1CP), IX( N1CP),12,11,16) >*/
lunscr_(&b[b_offset], n2c, &c__1, &ip[n1cp], &ix[n1cp], &c__12, &c__11, &
c__16);
/*< NBLSYM= NBLSYS >*/
matpar_1.nblsym = nblsys;
/*< NPSYM= NPSYS >*/
matpar_1.npsym = npsys;
/*< NLSYM= NLSYS >*/
matpar_1.nlsym = nlsys;
/*< ICASE= ICASS >*/
matpar_1.icase = icass;
/*< 13 RETURN >*/
L13:
return 0;
/*< END >*/
} /* facgf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FACIO( A, NROW, NOP, IP, IU1, IU2, IU3, IU4) >*/
/* Subroutine */ int facio_(a, nrow, nop, ip, iu1, iu2, iu3, iu4)
doublecomplex *a;
integer *nrow, *nop, *ip, *iu1, *iu2, *iu3, *iu4;
{
/* Format strings */
static char fmt_4[] = "(\002 CP TIME TAKEN FOR FACTORIZATION = \002,1p,e\
12.5)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
alist al__1;
/* Builtin functions */
integer f_rew(), s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static doublereal time;
static integer ixbp, i1, i2, i3, i4;
static doublereal t1, t2;
static integer ifile3, ifile4, ixblk1, ixblk2, ka, kk, it;
extern /* Subroutine */ int blckin_(), lfactr_(), blckot_(), secnds_();
static integer nbm;
/* Fortran I/O blocks */
static cilist io___747 = { 0, 6, 0, fmt_4, 0 };
/* *** */
/* FACIO CONTROLS I/O FOR OUT-OF-CORE FACTORIZATION */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMPLEX A >*/
/*< >*/
/*< DIMENSION A( NROW,1), IP( NROW) >*/
/*< IT=2* NPSYM* NROW >*/
/* Parameter adjustments */
--ip;
a_dim1 = *nrow;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
it = (matpar_1.npsym << 1) * *nrow;
/*< NBM= NBLSYM-1 >*/
nbm = matpar_1.nblsym - 1;
/*< I1=1 >*/
i1 = 1;
/*< I2= IT >*/
i2 = it;
/*< I3= I2+1 >*/
i3 = i2 + 1;
/*< I4=2* IT >*/
i4 = it << 1;
/*< TIME=0. >*/
time = 0.;
/*< REWIND IU1 >*/
al__1.aerr = 0;
al__1.aunit = *iu1;
f_rew(&al__1);
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< DO 3 KK=1, NOP >*/
i__1 = *nop;
for (kk = 1; kk <= i__1; ++kk) {
/*< KA=( KK-1)* NROW+1 >*/
ka = (kk - 1) * *nrow + 1;
/*< IFILE3= IU1 >*/
ifile3 = *iu1;
/*< IFILE4= IU3 >*/
ifile4 = *iu3;
/*< DO 2 IXBLK1=1, NBM >*/
i__2 = nbm;
for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< REWIND IU4 >*/
al__1.aerr = 0;
al__1.aunit = *iu4;
f_rew(&al__1);
/*< CALL BLCKIN( A, IFILE3, I1, I2,1,17) >*/
blckin_(&a[a_offset], &ifile3, &i1, &i2, &c__1, &c__17);
/*< IXBP= IXBLK1+1 >*/
ixbp = ixblk1 + 1;
/*< DO 1 IXBLK2= IXBP, NBLSYM >*/
i__3 = matpar_1.nblsym;
for (ixblk2 = ixbp; ixblk2 <= i__3; ++ixblk2) {
/*< CALL BLCKIN( A, IFILE3, I3, I4,1,18) >*/
blckin_(&a[a_offset], &ifile3, &i3, &i4, &c__1, &c__18);
/*< CALL SECNDS( T1) >*/
secnds_(&t1);
/*< CALL LFACTR( A, NROW, IXBLK1, IXBLK2, IP( KA)) >*/
lfactr_(&a[a_offset], nrow, &ixblk1, &ixblk2, &ip[ka]);
/*< CALL SECNDS( T2) >*/
secnds_(&t2);
/*< TIME= TIME+ T2- T1 >*/
time = time + t2 - t1;
/*< IF( IXBLK2.EQ. IXBP) CALL BLCKOT( A, IU2, I1, I2,1,19) >*/
if (ixblk2 == ixbp) {
blckot_(&a[a_offset], iu2, &i1, &i2, &c__1, &c__19);
}
/*< IF( IXBLK1.EQ. NBM.AND. IXBLK2.EQ. NBLSYM) IFILE4= IU2 >*/
if (ixblk1 == nbm && ixblk2 == matpar_1.nblsym) {
ifile4 = *iu2;
}
/*< CALL BLCKOT( A, IFILE4, I3, I4,1,20) >*/
blckot_(&a[a_offset], &ifile4, &i3, &i4, &c__1, &c__20);
/*< 1 CONTINUE >*/
/* L1: */
}
/*< IFILE3= IU3 >*/
ifile3 = *iu3;
/*< IFILE4= IU4 >*/
ifile4 = *iu4;
/*< IF(( IXBLK1/2)*2.NE. IXBLK1) GOTO 2 >*/
if (ixblk1 / 2 << 1 != ixblk1) {
goto L2;
}
/*< IFILE3= IU4 >*/
ifile3 = *iu4;
/*< IFILE4= IU3 >*/
ifile4 = *iu3;
/*< 2 CONTINUE >*/
L2:
;
}
/*< 3 CONTINUE >*/
/* L3: */
}
/*< REWIND IU1 >*/
al__1.aerr = 0;
al__1.aunit = *iu1;
f_rew(&al__1);
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< REWIND IU4 >*/
al__1.aerr = 0;
al__1.aunit = *iu4;
f_rew(&al__1);
/*< WRITE( 6,4) TIME >*/
s_wsfe(&io___747);
do_fio(&c__1, (char *)&time, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< RETURN >*/
return 0;
/*< 4 FORMAT(' CP TIME TAKEN FOR FACTORIZATION = ',1P,E12.5) >*/
/*< END >*/
} /* facio_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FACTR( N, A, IP, NDIM) >*/
/* Subroutine */ int factr_(n, a, ip, ndim)
integer *n;
doublecomplex *a;
integer *ip, *ndim;
{
/* Format strings */
static char fmt_10[] = "(\002 \002,\002PIVOT(\002,i3,\002)=\002,1p,e16.8)"
;
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(), z_div();
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static integer iflg;
static doublereal dmax_;
static integer i, j, k, r;
static doublereal elmag;
static integer pj, pr, jp1, rm1, rp1;
static doublecomplex arj;
/* Fortran I/O blocks */
static cilist io___761 = { 0, 6, 0, fmt_10, 0 };
/* *** */
/* SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX
*/
/* AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
*/
/* PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN */
/* NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN RALSTONS
*/
/* TEXT. (MATRIX TRANSPOSED. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, D, ARJ >*/
/*< DIMENSION A( NDIM, NDIM), IP( NDIM) >*/
/*< COMMON /SCRATM/ D( N2M) >*/
/*< INTEGER R, RM1, RP1, PJ, PR >*/
/*< IFLG=0 >*/
/* Parameter adjustments */
--ip;
a_dim1 = *ndim;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
iflg = 0;
/* STEP 1 */
/*< DO 9 R=1, N >*/
i__1 = *n;
for (r = 1; r <= i__1; ++r) {
/*< DO 1 K=1, N >*/
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/*< D( K)= A( R, K) >*/
i__3 = k - 1;
i__4 = r + k * a_dim1;
scratm_1.d[i__3].r = a[i__4].r, scratm_1.d[i__3].i = a[i__4].i;
/* STEPS 2 AND 3 */
/*< 1 CONTINUE >*/
/* L1: */
}
/*< RM1= R-1 >*/
rm1 = r - 1;
/*< IF( RM1.LT.1) GOTO 4 >*/
if (rm1 < 1) {
goto L4;
}
/*< DO 3 J=1, RM1 >*/
i__2 = rm1;
for (j = 1; j <= i__2; ++j) {
/*< PJ= IP( J) >*/
pj = ip[j];
/*< ARJ= D( PJ) >*/
i__3 = pj - 1;
arj.r = scratm_1.d[i__3].r, arj.i = scratm_1.d[i__3].i;
/*< A( R, J)= ARJ >*/
i__3 = r + j * a_dim1;
a[i__3].r = arj.r, a[i__3].i = arj.i;
/*< D( PJ)= D( J) >*/
i__3 = pj - 1;
i__4 = j - 1;
scratm_1.d[i__3].r = scratm_1.d[i__4].r, scratm_1.d[i__3].i =
scratm_1.d[i__4].i;
/*< JP1= J+1 >*/
jp1 = j + 1;
/*< DO 2 I= JP1, N >*/
i__3 = *n;
for (i = jp1; i <= i__3; ++i) {
/*< D( I)= D( I)- A( J, I)* ARJ >*/
i__4 = i - 1;
i__5 = i - 1;
i__6 = j + i * a_dim1;
z__2.r = a[i__6].r * arj.r - a[i__6].i * arj.i, z__2.i = a[
i__6].r * arj.i + a[i__6].i * arj.r;
z__1.r = scratm_1.d[i__5].r - z__2.r, z__1.i = scratm_1.d[
i__5].i - z__2.i;
scratm_1.d[i__4].r = z__1.r, scratm_1.d[i__4].i = z__1.i;
/*< 2 CONTINUE >*/
/* L2: */
}
/*< 3 CONTINUE >*/
/* L3: */
}
/* STEP 4 */
/*< 4 CONTINUE >*/
L4:
/*< DMAX= REAL( D( R)* CONJG( D( R))) >*/
i__2 = r - 1;
d_cnjg(&z__2, &scratm_1.d[r - 1]);
z__1.r = scratm_1.d[i__2].r * z__2.r - scratm_1.d[i__2].i * z__2.i,
z__1.i = scratm_1.d[i__2].r * z__2.i + scratm_1.d[i__2].i *
z__2.r;
dmax_ = z__1.r;
/*< IP( R)= R >*/
ip[r] = r;
/*< RP1= R+1 >*/
rp1 = r + 1;
/*< IF( RP1.GT. N) GOTO 6 >*/
if (rp1 > *n) {
goto L6;
}
/*< DO 5 I= RP1, N >*/
i__2 = *n;
for (i = rp1; i <= i__2; ++i) {
/*< ELMAG= REAL( D( I)* CONJG( D( I))) >*/
i__3 = i - 1;
d_cnjg(&z__2, &scratm_1.d[i - 1]);
z__1.r = scratm_1.d[i__3].r * z__2.r - scratm_1.d[i__3].i *
z__2.i, z__1.i = scratm_1.d[i__3].r * z__2.i + scratm_1.d[
i__3].i * z__2.r;
elmag = z__1.r;
/*< IF( ELMAG.LT. DMAX) GOTO 5 >*/
if (elmag < dmax_) {
goto L5;
}
/*< DMAX= ELMAG >*/
dmax_ = elmag;
/*< IP( R)= I >*/
ip[r] = i;
/*< 5 CONTINUE >*/
L5:
;
}
/*< 6 CONTINUE >*/
L6:
/*< IF( DMAX.LT.1.D-10) IFLG=1 >*/
if (dmax_ < 1e-10) {
iflg = 1;
}
/*< PR= IP( R) >*/
pr = ip[r];
/*< A( R, R)= D( PR) >*/
i__2 = r + r * a_dim1;
i__3 = pr - 1;
a[i__2].r = scratm_1.d[i__3].r, a[i__2].i = scratm_1.d[i__3].i;
/* STEP 5 */
/*< D( PR)= D( R) >*/
i__2 = pr - 1;
i__3 = r - 1;
scratm_1.d[i__2].r = scratm_1.d[i__3].r, scratm_1.d[i__2].i =
scratm_1.d[i__3].i;
/*< IF( RP1.GT. N) GOTO 8 >*/
if (rp1 > *n) {
goto L8;
}
/*< ARJ=1./ A( R, R) >*/
z_div(&z__1, &c_b48, &a[r + r * a_dim1]);
arj.r = z__1.r, arj.i = z__1.i;
/*< DO 7 I= RP1, N >*/
i__2 = *n;
for (i = rp1; i <= i__2; ++i) {
/*< A( R, I)= D( I)* ARJ >*/
i__3 = r + i * a_dim1;
i__4 = i - 1;
z__1.r = scratm_1.d[i__4].r * arj.r - scratm_1.d[i__4].i * arj.i,
z__1.i = scratm_1.d[i__4].r * arj.i + scratm_1.d[i__4].i *
arj.r;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/*< 7 CONTINUE >*/
/* L7: */
}
/*< 8 CONTINUE >*/
L8:
/*< IF( IFLG.EQ.0) GOTO 9 >*/
if (iflg == 0) {
goto L9;
}
/*< WRITE( 6,10) R, DMAX >*/
s_wsfe(&io___761);
do_fio(&c__1, (char *)&r, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&dmax_, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IFLG=0 >*/
iflg = 0;
/*< 9 CONTINUE >*/
L9:
;
}
/*< RETURN >*/
return 0;
/*< 10 FORMAT(1H ,'PIVOT(',I3,')=',1P,E16.8) >*/
/*< END >*/
} /* factr_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FACTRS( NP, NROW, A, IP, IX, IU1, IU2, IU3, IU4) >*/
/* Subroutine */ int factrs_(np, nrow, a, ip, ix, iu1, iu2, iu3, iu4)
integer *np, *nrow;
doublecomplex *a;
integer *ip, *ix, *iu1, *iu2, *iu3, *iu4;
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
alist al__1;
/* Builtin functions */
integer f_rew(), s_wsue(), do_uio(), e_wsue(), s_rsue(), e_rsue();
/* Local variables */
static integer i, j, k, l;
extern /* Subroutine */ int facio_(), factr_();
static integer icols, i2, j2, ka, kk;
extern /* Subroutine */ int blckin_(), blckot_();
static integer icoldx;
extern /* Subroutine */ int lunscr_();
static integer ir1, ir2, nop, irr1, irr2;
/* Fortran I/O blocks */
static cilist io___774 = { 0, 0, 0, 0, 0 };
static cilist io___776 = { 0, 0, 0, 0, 0 };
static cilist io___778 = { 0, 0, 0, 0, 0 };
static cilist io___780 = { 0, 0, 0, 0, 0 };
/* *** */
/* FACTRS, FOR SYMMETRIC STRUCTURE, TRANSFORMS SUBMATRICIES TO FORM */
/* MATRICIES OF THE SYMMETRIC MODES AND CALLS ROUTINE TO FACTOR */
/* MATRICIES. IF NO SYMMETRY, THE ROUTINE IS CALLED TO FACTOR THE */
/* COMPLETE MATRIX. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMPLEX A >*/
/*< >*/
/*< DIMENSION A(1), IP( NROW), IX( NROW) >*/
/*< NOP= NROW/ NP >*/
/* Parameter adjustments */
--ix;
--ip;
--a;
/* Function Body */
nop = *nrow / *np;
/*< IF( ICASE.GT.2) GOTO 2 >*/
if (matpar_1.icase > 2) {
goto L2;
}
/*< DO 1 KK=1, NOP >*/
i__1 = nop;
for (kk = 1; kk <= i__1; ++kk) {
/*< KA=( KK-1)* NP+1 >*/
ka = (kk - 1) * *np + 1;
/*< 1 CALL FACTR( NP, A( KA), IP( KA), NROW) >*/
/* L1: */
factr_(np, &a[ka], &ip[ka], nrow);
}
/*< RETURN >*/
return 0;
/* FACTOR SUBMATRICIES, OR FACTOR COMPLETE MATRIX IF NO SYMMETRY */
/* EXISTS. */
/*< 2 IF( ICASE.GT.3) GOTO 3 >*/
L2:
if (matpar_1.icase > 3) {
goto L3;
}
/*< CALL FACIO( A, NROW, NOP, IX, IU1, IU2, IU3, IU4) >*/
facio_(&a[1], nrow, &nop, &ix[1], iu1, iu2, iu3, iu4);
/*< CALL LUNSCR( A, NROW, NOP, IP, IX, IU2, IU3, IU4) >*/
lunscr_(&a[1], nrow, &nop, &ip[1], &ix[1], iu2, iu3, iu4);
/* REWRITE THE MATRICES BY COLUMNS ON TAPE 13 */
/*< RETURN >*/
return 0;
/*< 3 I2=2* NPBLK* NROW >*/
L3:
i2 = (matpar_1.npblk << 1) * *nrow;
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< DO 5 K=1, NOP >*/
i__1 = nop;
for (k = 1; k <= i__1; ++k) {
/*< REWIND IU1 >*/
al__1.aerr = 0;
al__1.aunit = *iu1;
f_rew(&al__1);
/*< ICOLS= NPBLK >*/
icols = matpar_1.npblk;
/*< IR2= K* NP >*/
ir2 = k * *np;
/*< IR1= IR2- NP+1 >*/
ir1 = ir2 - *np + 1;
/*< DO 5 L=1, NBLOKS >*/
i__2 = matpar_1.nbloks;
for (l = 1; l <= i__2; ++l) {
/*< IF( NBLOKS.EQ.1.AND. K.GT.1) GOTO 4 >*/
if (matpar_1.nbloks == 1 && k > 1) {
goto L4;
}
/*< CALL BLCKIN( A, IU1,1, I2,1,602) >*/
blckin_(&a[1], iu1, &c__1, &i2, &c__1, &c__602);
/*< IF( L.EQ. NBLOKS) ICOLS= NLAST >*/
if (l == matpar_1.nbloks) {
icols = matpar_1.nlast;
}
/*< 4 IRR1= IR1 >*/
L4:
irr1 = ir1;
/*< IRR2= IR2 >*/
irr2 = ir2;
/*< DO 5 ICOLDX=1, ICOLS >*/
i__3 = icols;
for (icoldx = 1; icoldx <= i__3; ++icoldx) {
/*< WRITE( IU2) ( A( I), I= IRR1, IRR2) >*/
io___774.ciunit = *iu2;
s_wsue(&io___774);
i__4 = irr2;
for (i = irr1; i <= i__4; ++i) {
do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< IRR1= IRR1+ NROW >*/
irr1 += *nrow;
/*< IRR2= IRR2+ NROW >*/
irr2 += *nrow;
/*< 5 CONTINUE >*/
/* L5: */
}
}
}
/*< REWIND IU1 >*/
al__1.aerr = 0;
al__1.aunit = *iu1;
f_rew(&al__1);
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< IF( ICASE.EQ.5) GOTO 8 >*/
if (matpar_1.icase == 5) {
goto L8;
}
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< IRR1= NP* NP >*/
irr1 = *np * *np;
/*< DO 7 KK=1, NOP >*/
i__3 = nop;
for (kk = 1; kk <= i__3; ++kk) {
/*< IR1=1- NP >*/
ir1 = 1 - *np;
/*< IR2=0 >*/
ir2 = 0;
/*< DO 6 I=1, NP >*/
i__2 = *np;
for (i = 1; i <= i__2; ++i) {
/*< IR1= IR1+ NP >*/
ir1 += *np;
/*< IR2= IR2+ NP >*/
ir2 += *np;
/*< 6 READ( IU2) ( A( J), J= IR1, IR2) >*/
/* L6: */
io___776.ciunit = *iu2;
s_rsue(&io___776);
i__1 = ir2;
for (j = ir1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&a[j], (ftnlen)sizeof(doublereal));
}
e_rsue();
}
/*< KA=( KK-1)* NP+1 >*/
ka = (kk - 1) * *np + 1;
/*< CALL FACTR( NP, A, IP( KA), NP) >*/
factr_(np, &a[1], &ip[ka], np);
/*< WRITE( IU3) ( A( I), I=1, IRR1) >*/
io___778.ciunit = *iu3;
s_wsue(&io___778);
i__1 = irr1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< 7 CONTINUE >*/
/* L7: */
}
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< RETURN >*/
return 0;
/*< 8 I2=2* NPSYM* NP >*/
L8:
i2 = (matpar_1.npsym << 1) * *np;
/*< DO 10 KK=1, NOP >*/
i__3 = nop;
for (kk = 1; kk <= i__3; ++kk) {
/*< J2= NPSYM >*/
j2 = matpar_1.npsym;
/*< DO 10 L=1, NBLSYM >*/
i__1 = matpar_1.nblsym;
for (l = 1; l <= i__1; ++l) {
/*< IF( L.EQ. NBLSYM) J2= NLSYM >*/
if (l == matpar_1.nblsym) {
j2 = matpar_1.nlsym;
}
/*< IR1=1- NP >*/
ir1 = 1 - *np;
/*< IR2=0 >*/
ir2 = 0;
/*< DO 9 J=1, J2 >*/
i__2 = j2;
for (j = 1; j <= i__2; ++j) {
/*< IR1= IR1+ NP >*/
ir1 += *np;
/*< IR2= IR2+ NP >*/
ir2 += *np;
/*< 9 READ( IU2) ( A( I), I= IR1, IR2) >*/
/* L9: */
io___780.ciunit = *iu2;
s_rsue(&io___780);
i__4 = ir2;
for (i = ir1; i <= i__4; ++i) {
do_uio(&c__2, (char *)&a[i], (ftnlen)sizeof(doublereal));
}
e_rsue();
}
/*< 10 CALL BLCKOT( A, IU1,1, I2,1,193) >*/
/* L10: */
blckot_(&a[1], iu1, &c__1, &i2, &c__1, &c__193);
}
}
/*< REWIND IU1 >*/
al__1.aerr = 0;
al__1.aunit = *iu1;
f_rew(&al__1);
/*< CALL FACIO( A, NP, NOP, IX, IU1, IU2, IU3, IU4) >*/
facio_(&a[1], np, &nop, &ix[1], iu1, iu2, iu3, iu4);
/*< CALL LUNSCR( A, NP, NOP, IP, IX, IU2, IU3, IU4) >*/
lunscr_(&a[1], np, &nop, &ip[1], &ix[1], iu2, iu3, iu4);
/*< RETURN >*/
return 0;
/*< END >*/
} /* factrs_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/* jcb COMPLEX FUNCTION FBAR( P) */
/*< FUNCTION FBAR( P) >*/
/* Double Complex */ int fbar_( ret_val, p)
doublecomplex * ret_val;
doublecomplex *p;
{
/* Initialized data */
static doublereal tosp = 1.128379167;
static doublereal accs = 1e-12;
static doublereal sp = 1.772453851;
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 1., 0. };
/* System generated locals */
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
void z_sqrt();
double z_abs();
void d_cnjg(), z_exp(), z_div();
/* Local variables */
static doublecomplex term;
static integer i;
static doublecomplex z;
static integer minus;
#define fj ((doublecomplex *)&equiv_0)
static doublecomplex zs;
#define fjx ((doublereal *)&equiv_0)
static doublereal sms, tms;
static doublecomplex sum, pow;
/* *** */
/* FBAR IS SOMMERFELD ATTENUATION FUNCTION FOR NUMERICAL DISTANCE P */
/* jcb IMPLICIT DOUBLE PRECISION (A-H,O-Z) */
/*< COMPLEX Z, ZS, SUM, POW, TERM, P, FJ, FBAR >*/
/*< DIMENSION FJX(2) >*/
/*< EQUIVALENCE(FJ,FJX) >*/
/*< >*/
/*< Z= FJ* SQRT( P) >*/
z_sqrt(&z__2, p);
z__1.r = fj->r * z__2.r - fj->i * z__2.i, z__1.i = fj->r * z__2.i + fj->i
* z__2.r;
z.r = z__1.r, z.i = z__1.i;
/* SERIES EXPANSION */
/*< IF( ABS( Z).GT.3.) GOTO 3 >*/
if (z_abs(&z) > 3.) {
goto L3;
}
/*< ZS= Z* Z >*/
z__1.r = z.r * z.r - z.i * z.i, z__1.i = z.r * z.i + z.i * z.r;
zs.r = z__1.r, zs.i = z__1.i;
/*< SUM= Z >*/
sum.r = z.r, sum.i = z.i;
/*< POW= Z >*/
pow.r = z.r, pow.i = z.i;
/*< DO 1 I=1,100 >*/
for (i = 1; i <= 100; ++i) {
/*< POW=- POW* ZS/ DFLOAT( I) >*/
z__3.r = -pow.r, z__3.i = -pow.i;
z__2.r = z__3.r * zs.r - z__3.i * zs.i, z__2.i = z__3.r * zs.i +
z__3.i * zs.r;
d__1 = (doublereal) i;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
pow.r = z__1.r, pow.i = z__1.i;
/*< TERM= POW/(2.* I+1.) >*/
d__1 = i * 2. + 1.;
z__1.r = pow.r / d__1, z__1.i = pow.i / d__1;
term.r = z__1.r, term.i = z__1.i;
/*< SUM= SUM+ TERM >*/
z__1.r = sum.r + term.r, z__1.i = sum.i + term.i;
sum.r = z__1.r, sum.i = z__1.i;
/*< TMS= REAL( TERM* CONJG( TERM)) >*/
d_cnjg(&z__2, &term);
z__1.r = term.r * z__2.r - term.i * z__2.i, z__1.i = term.r * z__2.i
+ term.i * z__2.r;
tms = z__1.r;
/*< SMS= REAL( SUM* CONJG( SUM)) >*/
d_cnjg(&z__2, &sum);
z__1.r = sum.r * z__2.r - sum.i * z__2.i, z__1.i = sum.r * z__2.i +
sum.i * z__2.r;
sms = z__1.r;
/*< IF( TMS/ SMS.LT. ACCS) GOTO 2 >*/
if (tms / sms < accs) {
goto L2;
}
/*< 1 CONTINUE >*/
/* L1: */
}
/*< 2 FBAR=1.-(1.- SUM* TOSP)* Z* EXP( ZS)* SP >*/
L2:
z__6.r = tosp * sum.r, z__6.i = tosp * sum.i;
z__5.r = 1. - z__6.r, z__5.i = -z__6.i;
z__4.r = z__5.r * z.r - z__5.i * z.i, z__4.i = z__5.r * z.i + z__5.i *
z.r;
z_exp(&z__7, &zs);
z__3.r = z__4.r * z__7.r - z__4.i * z__7.i, z__3.i = z__4.r * z__7.i +
z__4.i * z__7.r;
z__2.r = sp * z__3.r, z__2.i = sp * z__3.i;
z__1.r = 1. - z__2.r, z__1.i = -z__2.i;
ret_val->r = z__1.r, ret_val->i = z__1.i;
/* ASYMPTOTIC EXPANSION */
/*< RETURN >*/
return ;
/*< 3 IF( REAL( Z).GE.0.) GOTO 4 >*/
L3:
if (z.r >= 0.) {
goto L4;
}
/*< MINUS=1 >*/
minus = 1;
/*< Z=- Z >*/
z__1.r = -z.r, z__1.i = -z.i;
z.r = z__1.r, z.i = z__1.i;
/*< GOTO 5 >*/
goto L5;
/*< 4 MINUS=0 >*/
L4:
minus = 0;
/*< 5 ZS=.5/( Z* Z) >*/
L5:
z__2.r = z.r * z.r - z.i * z.i, z__2.i = z.r * z.i + z.i * z.r;
z_div(&z__1, &c_b1190, &z__2);
zs.r = z__1.r, zs.i = z__1.i;
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< TERM=(1.,0.) >*/
term.r = 1., term.i = 0.;
/*< DO 6 I=1,6 >*/
for (i = 1; i <= 6; ++i) {
/*< TERM=- TERM*(2.* I-1.)* ZS >*/
z__3.r = -term.r, z__3.i = -term.i;
d__1 = i * 2. - 1.;
z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
z__1.r = z__2.r * zs.r - z__2.i * zs.i, z__1.i = z__2.r * zs.i +
z__2.i * zs.r;
term.r = z__1.r, term.i = z__1.i;
/*< 6 SUM= SUM+ TERM >*/
/* L6: */
z__1.r = sum.r + term.r, z__1.i = sum.i + term.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< IF( MINUS.EQ.1) SUM= SUM-2.* SP* Z* EXP( Z* Z) >*/
if (minus == 1) {
d__1 = sp * 2.;
z__3.r = d__1 * z.r, z__3.i = d__1 * z.i;
z__5.r = z.r * z.r - z.i * z.i, z__5.i = z.r * z.i + z.i * z.r;
z_exp(&z__4, &z__5);
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i
+ z__3.i * z__4.r;
z__1.r = sum.r - z__2.r, z__1.i = sum.i - z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< FBAR=- SUM >*/
z__1.r = -sum.r, z__1.i = -sum.i;
ret_val->r = z__1.r, ret_val->i = z__1.i;
/*< RETURN >*/
return ;
/*< END >*/
} /* fbar_ */
#undef fjx
#undef fj
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FBLOCK( NROW, NCOL, IMAX, IRNGF, IPSYM) >*/
/* Subroutine */ int fblock_(nrow, ncol, imax, irngf, ipsym)
integer *nrow, *ncol, *imax, *irngf, *ipsym;
{
/* Format strings */
static char fmt_14[] = "(//\002 MATRIX FILE STORAGE - NO. BLOCKS=\002,i\
5,\002 COLUMNS PE\002,\002R BLOCK=\002,i5,\002 COLUMNS IN LAST BLOCK=\002,i5)"
;
static char fmt_15[] = "(\002 SUBMATRICIES FIT IN CORE\002)";
static char fmt_16[] = "(\002 SUBMATRIX PARTITIONING - NO. BLOCKS=\002,\
i5,\002 COLUMNS P\002,\002ER BLOCK=\002,i5,\002 COLUMNS IN LAST BLOCK=\002,i\
5)";
static char fmt_17[] = "(\002 ERROR - INSUFFICIENT STORAGE FOR MATRIX\
\002,2i5)";
static char fmt_18[] = "(\002 SYMMETRY ERROR - NROW,NCOL=\002,2i5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
double cos(), sin();
/* Subroutine */ int s_stop();
/* Local variables */
static doublereal phaz;
static integer i, j, k;
static doublecomplex deter;
static integer ka, kk;
static doublereal arg;
static integer nop, imx1;
/* Fortran I/O blocks */
static cilist io___796 = { 0, 6, 0, fmt_14, 0 };
static cilist io___797 = { 0, 6, 0, fmt_14, 0 };
static cilist io___798 = { 0, 6, 0, fmt_15, 0 };
static cilist io___799 = { 0, 6, 0, fmt_16, 0 };
static cilist io___809 = { 0, 6, 0, fmt_17, 0 };
static cilist io___810 = { 0, 6, 0, fmt_18, 0 };
/* *** */
/* FBLOCK SETS PARAMETERS FOR OUT-OF-CORE SOLUTION FOR THE PRIMARY */
/* MATRIX (A) */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX SSX, DETER >*/
/*< >*/
/*< COMMON /SMAT/ SSX(16,16) >*/
/*< IMX1= IMAX- IRNGF >*/
imx1 = *imax - *irngf;
/*< IF( NROW* NCOL.GT. IMX1) GOTO 2 >*/
if (*nrow * *ncol > imx1) {
goto L2;
}
/*< NBLOKS=1 >*/
matpar_1.nbloks = 1;
/*< NPBLK= NROW >*/
matpar_1.npblk = *nrow;
/*< NLAST= NROW >*/
matpar_1.nlast = *nrow;
/*< IMAT= NROW* NCOL >*/
matpar_1.imat = *nrow * *ncol;
/*< IF( NROW.NE. NCOL) GOTO 1 >*/
if (*nrow != *ncol) {
goto L1;
}
/*< ICASE=1 >*/
matpar_1.icase = 1;
/*< RETURN >*/
return 0;
/*< 1 ICASE=2 >*/
L1:
matpar_1.icase = 2;
/*< GOTO 5 >*/
goto L5;
/*< 2 IF( NROW.NE. NCOL) GOTO 3 >*/
L2:
if (*nrow != *ncol) {
goto L3;
}
/*< ICASE=3 >*/
matpar_1.icase = 3;
/*< NPBLK= IMAX/(2* NCOL) >*/
matpar_1.npblk = *imax / (*ncol << 1);
/*< NPSYM= IMX1/ NCOL >*/
matpar_1.npsym = imx1 / *ncol;
/*< IF( NPSYM.LT. NPBLK) NPBLK= NPSYM >*/
if (matpar_1.npsym < matpar_1.npblk) {
matpar_1.npblk = matpar_1.npsym;
}
/*< IF( NPBLK.LT.1) GOTO 12 >*/
if (matpar_1.npblk < 1) {
goto L12;
}
/*< NBLOKS=( NROW-1)/ NPBLK >*/
matpar_1.nbloks = (*nrow - 1) / matpar_1.npblk;
/*< NLAST= NROW- NBLOKS* NPBLK >*/
matpar_1.nlast = *nrow - matpar_1.nbloks * matpar_1.npblk;
/*< NBLOKS= NBLOKS+1 >*/
++matpar_1.nbloks;
/*< NBLSYM= NBLOKS >*/
matpar_1.nblsym = matpar_1.nbloks;
/*< NPSYM= NPBLK >*/
matpar_1.npsym = matpar_1.npblk;
/*< NLSYM= NLAST >*/
matpar_1.nlsym = matpar_1.nlast;
/*< IMAT= NPBLK* NCOL >*/
matpar_1.imat = matpar_1.npblk * *ncol;
/*< WRITE( 6,14) NBLOKS, NPBLK, NLAST >*/
s_wsfe(&io___796);
do_fio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
e_wsfe();
/*< GOTO 11 >*/
goto L11;
/*< 3 NPBLK= IMAX/ NCOL >*/
L3:
matpar_1.npblk = *imax / *ncol;
/*< IF( NPBLK.LT.1) GOTO 12 >*/
if (matpar_1.npblk < 1) {
goto L12;
}
/*< IF( NPBLK.GT. NROW) NPBLK= NROW >*/
if (matpar_1.npblk > *nrow) {
matpar_1.npblk = *nrow;
}
/*< NBLOKS=( NROW-1)/ NPBLK >*/
matpar_1.nbloks = (*nrow - 1) / matpar_1.npblk;
/*< NLAST= NROW- NBLOKS* NPBLK >*/
matpar_1.nlast = *nrow - matpar_1.nbloks * matpar_1.npblk;
/*< NBLOKS= NBLOKS+1 >*/
++matpar_1.nbloks;
/*< WRITE( 6,14) NBLOKS, NPBLK, NLAST >*/
s_wsfe(&io___797);
do_fio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( NROW* NROW.GT. IMX1) GOTO 4 >*/
if (*nrow * *nrow > imx1) {
goto L4;
}
/*< ICASE=4 >*/
matpar_1.icase = 4;
/*< NBLSYM=1 >*/
matpar_1.nblsym = 1;
/*< NPSYM= NROW >*/
matpar_1.npsym = *nrow;
/*< NLSYM= NROW >*/
matpar_1.nlsym = *nrow;
/*< IMAT= NROW* NROW >*/
matpar_1.imat = *nrow * *nrow;
/*< WRITE( 6,15) >*/
s_wsfe(&io___798);
e_wsfe();
/*< GOTO 5 >*/
goto L5;
/*< 4 ICASE=5 >*/
L4:
matpar_1.icase = 5;
/*< NPSYM= IMAX/(2* NROW) >*/
matpar_1.npsym = *imax / (*nrow << 1);
/*< NBLSYM= IMX1/ NROW >*/
matpar_1.nblsym = imx1 / *nrow;
/*< IF( NBLSYM.LT. NPSYM) NPSYM= NBLSYM >*/
if (matpar_1.nblsym < matpar_1.npsym) {
matpar_1.npsym = matpar_1.nblsym;
}
/*< IF( NPSYM.LT.1) GOTO 12 >*/
if (matpar_1.npsym < 1) {
goto L12;
}
/*< NBLSYM=( NROW-1)/ NPSYM >*/
matpar_1.nblsym = (*nrow - 1) / matpar_1.npsym;
/*< NLSYM= NROW- NBLSYM* NPSYM >*/
matpar_1.nlsym = *nrow - matpar_1.nblsym * matpar_1.npsym;
/*< NBLSYM= NBLSYM+1 >*/
++matpar_1.nblsym;
/*< WRITE( 6,16) NBLSYM, NPSYM, NLSYM >*/
s_wsfe(&io___799);
do_fio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
e_wsfe();
/*< IMAT= NPSYM* NROW >*/
matpar_1.imat = matpar_1.npsym * *nrow;
/*< 5 NOP= NCOL/ NROW >*/
L5:
nop = *ncol / *nrow;
/*< IF( NOP* NROW.NE. NCOL) GOTO 13 >*/
if (nop * *nrow != *ncol) {
goto L13;
}
/* SET UP SSX MATRIX FOR ROTATIONAL SYMMETRY. */
/*< IF( IPSYM.GT.0) GOTO 7 >*/
if (*ipsym > 0) {
goto L7;
}
/*< PHAZ=6.2831853072D+0/ NOP >*/
phaz = 6.2831853072 / nop;
/*< DO 6 I=2, NOP >*/
i__1 = nop;
for (i = 2; i <= i__1; ++i) {
/*< DO 6 J= I, NOP >*/
i__2 = nop;
for (j = i; j <= i__2; ++j) {
/*< ARG= PHAZ* DFLOAT( I-1)* DFLOAT( J-1) >*/
d__1 = phaz * (doublereal) (i - 1);
arg = d__1 * (doublereal) (j - 1);
/*< SSX( I, J)= CMPLX( COS( ARG), SIN( ARG)) >*/
i__3 = i + (j << 4) - 17;
d__1 = cos(arg);
d__2 = sin(arg);
z__1.r = d__1, z__1.i = d__2;
smat_1.ssx[i__3].r = z__1.r, smat_1.ssx[i__3].i = z__1.i;
/*< 6 SSX( J, I)= SSX( I, J) >*/
/* L6: */
i__3 = j + (i << 4) - 17;
i__4 = i + (j << 4) - 17;
smat_1.ssx[i__3].r = smat_1.ssx[i__4].r, smat_1.ssx[i__3].i =
smat_1.ssx[i__4].i;
}
}
/* SET UP SSX MATRIX FOR PLANE SYMMETRY */
/*< GOTO 11 >*/
goto L11;
/*< 7 KK=1 >*/
L7:
kk = 1;
/*< SSX(1,1)=(1.,0.) >*/
smat_1.ssx[0].r = 1., smat_1.ssx[0].i = 0.;
/*< IF(( NOP.EQ.2).OR.( NOP.EQ.4).OR.( NOP.EQ.8)) GOTO 8 >*/
if (nop == 2 || nop == 4 || nop == 8) {
goto L8;
}
/*< STOP >*/
s_stop("", 0L);
/*< 8 KA= NOP/2 >*/
L8:
ka = nop / 2;
/*< IF( NOP.EQ.8) KA=3 >*/
if (nop == 8) {
ka = 3;
}
/*< DO 10 K=1, KA >*/
i__3 = ka;
for (k = 1; k <= i__3; ++k) {
/*< DO 9 I=1, KK >*/
i__4 = kk;
for (i = 1; i <= i__4; ++i) {
/*< DO 9 J=1, KK >*/
i__2 = kk;
for (j = 1; j <= i__2; ++j) {
/*< DETER= SSX( I, J) >*/
i__1 = i + (j << 4) - 17;
deter.r = smat_1.ssx[i__1].r, deter.i = smat_1.ssx[i__1].i;
/*< SSX( I, J+ KK)= DETER >*/
i__1 = i + (j + kk << 4) - 17;
smat_1.ssx[i__1].r = deter.r, smat_1.ssx[i__1].i = deter.i;
/*< SSX( I+ KK, J+ KK)=- DETER >*/
i__1 = i + kk + (j + kk << 4) - 17;
z__1.r = -deter.r, z__1.i = -deter.i;
smat_1.ssx[i__1].r = z__1.r, smat_1.ssx[i__1].i = z__1.i;
/*< 9 SSX( I+ KK, J)= DETER >*/
/* L9: */
i__1 = i + kk + (j << 4) - 17;
smat_1.ssx[i__1].r = deter.r, smat_1.ssx[i__1].i = deter.i;
}
}
/*< 10 KK= KK*2 >*/
/* L10: */
kk <<= 1;
}
/*< 11 RETURN >*/
L11:
return 0;
/*< 12 WRITE( 6,17) NROW, NCOL >*/
L12:
s_wsfe(&io___809);
do_fio(&c__1, (char *)&(*nrow), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ncol), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 13 WRITE( 6,18) NROW, NCOL >*/
L13:
s_wsfe(&io___810);
do_fio(&c__1, (char *)&(*nrow), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*ncol), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< >*/
/*< 15 FORMAT(' SUBMATRICIES FIT IN CORE') >*/
/*< >*/
/*< 17 FORMAT(' ERROR - INSUFFICIENT STORAGE FOR MATRIX',2I5) >*/
/*< 18 FORMAT(' SYMMETRY ERROR - NROW,NCOL=',2I5) >*/
/*< END >*/
} /* fblock_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FBNGF( NEQ, NEQ2, IRESRV, IB11, IC11, ID11, IX11) >*/
/* Subroutine */ int fbngf_(neq, neq2, iresrv, ib11, ic11, id11, ix11)
integer *neq, *neq2, *iresrv, *ib11, *ic11, *id11, *ix11;
{
/* Format strings */
static char fmt_11[] = "(//,\002 N.G.F. - NUMBER OF NEW UNKNOWNS IS\002,\
i4)";
static char fmt_8[] = "(\002 FILE STORAGE FOR NEW MATRIX SECTIONS - ICA\
SX =\002,i2)";
static char fmt_9[] = "(\002 B FILLED BY ROWS -\002,15x,\002NO. BLOCKS \
=\002,i3,3x,\002ROWS P\002,\002ER BLOCK =\002,i3,3x,\002ROWS IN LAST BLOCK \
=\002,i3)";
static char fmt_10[] = "(\002 B BY COLUMNS, C AND D BY ROWS -\002,2x,\
\002NO. BLOCKS =\002,i3,4x,\002R/C PER BLOCK =\002,i3,4x,\002R/C IN LAST BLO\
CK =\002,i3)";
static char fmt_7[] = "(\002 ERROR - INSUFFICIENT STORAGE FOR INTERACTIO\
N MATRICIES\002,\002 IRESRV,IMAT,NEQ,NEQ2 =\002,4i5)";
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer nbcd, nbln, ndln, iresx, ir;
/* Fortran I/O blocks */
static cilist io___816 = { 0, 6, 0, fmt_11, 0 };
static cilist io___817 = { 0, 6, 0, fmt_8, 0 };
static cilist io___818 = { 0, 6, 0, fmt_9, 0 };
static cilist io___819 = { 0, 6, 0, fmt_10, 0 };
static cilist io___820 = { 0, 6, 0, fmt_7, 0 };
/* *** */
/* FBNGF SETS THE BLOCKING PARAMETERS FOR THE B, C, AND D ARRAYS FOR
*/
/* OUT-OF-CORE STORAGE. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< IRESX= IRESRV- IMAT >*/
iresx = *iresrv - matpar_1.imat;
/*< NBLN= NEQ* NEQ2 >*/
nbln = *neq * *neq2;
/*< NDLN= NEQ2* NEQ2 >*/
ndln = *neq2 * *neq2;
/*< NBCD=2* NBLN+ NDLN >*/
nbcd = (nbln << 1) + ndln;
/*< IF( NBCD.GT. IRESX) GOTO 1 >*/
if (nbcd > iresx) {
goto L1;
}
/*< ICASX=1 >*/
matpar_1.icasx = 1;
/*< IB11= IMAT+1 >*/
*ib11 = matpar_1.imat + 1;
/*< GOTO 2 >*/
goto L2;
/*< 1 IF( ICASE.LT.3) GOTO 3 >*/
L1:
if (matpar_1.icase < 3) {
goto L3;
}
/*< IF( NBCD.GT. IRESRV.OR. NBLN.GT. IRESX) GOTO 3 >*/
if (nbcd > *iresrv || nbln > iresx) {
goto L3;
}
/*< ICASX=2 >*/
matpar_1.icasx = 2;
/*< IB11=1 >*/
*ib11 = 1;
/*< 2 NBBX=1 >*/
L2:
matpar_1.nbbx = 1;
/*< NPBX= NEQ >*/
matpar_1.npbx = *neq;
/*< NLBX= NEQ >*/
matpar_1.nlbx = *neq;
/*< NBBL=1 >*/
matpar_1.nbbl = 1;
/*< NPBL= NEQ2 >*/
matpar_1.npbl = *neq2;
/*< NLBL= NEQ2 >*/
matpar_1.nlbl = *neq2;
/*< GOTO 5 >*/
goto L5;
/*< 3 IR= IRESRV >*/
L3:
ir = *iresrv;
/*< IF( ICASE.LT.3) IR= IRESX >*/
if (matpar_1.icase < 3) {
ir = iresx;
}
/*< ICASX=3 >*/
matpar_1.icasx = 3;
/*< IF( NDLN.GT. IR) ICASX=4 >*/
if (ndln > ir) {
matpar_1.icasx = 4;
}
/*< NBCD=2* NEQ+ NEQ2 >*/
nbcd = (*neq << 1) + *neq2;
/*< NPBL= IR/ NBCD >*/
matpar_1.npbl = ir / nbcd;
/*< NLBL= IR/(2* NEQ2) >*/
matpar_1.nlbl = ir / (*neq2 << 1);
/*< IF( NLBL.LT. NPBL) NPBL= NLBL >*/
if (matpar_1.nlbl < matpar_1.npbl) {
matpar_1.npbl = matpar_1.nlbl;
}
/*< IF( ICASE.LT.3) GOTO 4 >*/
if (matpar_1.icase < 3) {
goto L4;
}
/*< NLBL= IRESX/ NEQ >*/
matpar_1.nlbl = iresx / *neq;
/*< IF( NLBL.LT. NPBL) NPBL= NLBL >*/
if (matpar_1.nlbl < matpar_1.npbl) {
matpar_1.npbl = matpar_1.nlbl;
}
/*< 4 IF( NPBL.LT.1) GOTO 6 >*/
L4:
if (matpar_1.npbl < 1) {
goto L6;
}
/*< NBBL=( NEQ2-1)/ NPBL >*/
matpar_1.nbbl = (*neq2 - 1) / matpar_1.npbl;
/*< NLBL= NEQ2- NBBL* NPBL >*/
matpar_1.nlbl = *neq2 - matpar_1.nbbl * matpar_1.npbl;
/*< NBBL= NBBL+1 >*/
++matpar_1.nbbl;
/*< NBLN= NEQ* NPBL >*/
nbln = *neq * matpar_1.npbl;
/*< IR= IR- NBLN >*/
ir -= nbln;
/*< NPBX= IR/ NEQ2 >*/
matpar_1.npbx = ir / *neq2;
/*< IF( NPBX.GT. NEQ) NPBX= NEQ >*/
if (matpar_1.npbx > *neq) {
matpar_1.npbx = *neq;
}
/*< NBBX=( NEQ-1)/ NPBX >*/
matpar_1.nbbx = (*neq - 1) / matpar_1.npbx;
/*< NLBX= NEQ- NBBX* NPBX >*/
matpar_1.nlbx = *neq - matpar_1.nbbx * matpar_1.npbx;
/*< NBBX= NBBX+1 >*/
++matpar_1.nbbx;
/*< IB11=1 >*/
*ib11 = 1;
/*< IF( ICASE.LT.3) IB11= IMAT+1 >*/
if (matpar_1.icase < 3) {
*ib11 = matpar_1.imat + 1;
}
/*< 5 IC11= IB11+ NBLN >*/
L5:
*ic11 = *ib11 + nbln;
/*< ID11= IC11+ NBLN >*/
*id11 = *ic11 + nbln;
/*< IX11= IMAT+1 >*/
*ix11 = matpar_1.imat + 1;
/*< WRITE( 6,11) NEQ2 >*/
s_wsfe(&io___816);
do_fio(&c__1, (char *)&(*neq2), (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( ICASX.EQ.1) RETURN >*/
if (matpar_1.icasx == 1) {
return 0;
}
/*< WRITE( 6,8) ICASX >*/
s_wsfe(&io___817);
do_fio(&c__1, (char *)&matpar_1.icasx, (ftnlen)sizeof(integer));
e_wsfe();
/*< WRITE( 6,9) NBBX, NPBX, NLBX >*/
s_wsfe(&io___818);
do_fio(&c__1, (char *)&matpar_1.nbbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.npbx, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.nlbx, (ftnlen)sizeof(integer));
e_wsfe();
/*< WRITE( 6,10) NBBL, NPBL, NLBL >*/
s_wsfe(&io___819);
do_fio(&c__1, (char *)&matpar_1.nbbl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.npbl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.nlbl, (ftnlen)sizeof(integer));
e_wsfe();
/*< RETURN >*/
return 0;
/*< 6 WRITE( 6,7) IRESRV, IMAT, NEQ, NEQ2 >*/
L6:
s_wsfe(&io___820);
do_fio(&c__1, (char *)&(*iresrv), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*neq), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*neq2), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< >*/
/*< 8 FORMAT(48H FILE STORAGE FOR NEW MATRIX SECTIONS - ICASX =,I2) >*/
/*< >*/
/*< >*/
/*< 11 FORMAT(//,35H N.G.F. - NUMBER OF NEW UNKNOWNS IS,I4) >*/
/*< END >*/
} /* fbngf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FFLD( THET, PHI, ETH, EPH) >*/
/* Subroutine */ int ffld_(thet, phi, eth, eph)
doublereal *thet, *phi;
doublecomplex *eth, *eph;
{
/* Initialized data */
static doublereal pi = 3.141592654;
static doublereal tp = 6.283185308;
static doublereal eta = 376.73;
static struct {
doublereal e_1[3];
} equiv_2 = { 0., -29.97922085, 0. };
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Builtin functions */
double sin(), cos();
void z_sqrt(), z_div();
double tan(), sqrt(), log();
/* Local variables */
static doublereal darg, sill, rozs, a, b, c, d;
static integer i, k;
static doublereal omega;
extern /* Subroutine */ int fflds_();
#define const_ ((doublecomplex *)&equiv_2)
static doublereal tthet;
#define consx ((doublereal *)&equiv_2)
static doublecomplex zscrn, zrsin;
static doublereal el, dr;
static integer ip;
static doublecomplex ex, ey, ez, gx, gy, gz;
static doublereal rr, ri;
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex cdp, exa, ccx, ccy, ccz, cix, ciy, ciz, rrh;
static doublereal bot, phx, phy, too, top, thx;
static doublecomplex tix, tiy, tiz;
static doublereal thy, thz;
static doublecomplex rrv;
static doublereal roz, rox, roy, boo, arg, rfl, rrz;
static doublecomplex rrh1, rrh2, rrv1, rrv2;
/* *** */
/* FFLD CALCULATES THE FAR ZONE RADIATED ELECTRIC FIELDS, */
/* THE FACTOR EXP(J*K*R)/(R/LAMDA) NOT INCLUDED */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< DIMENSION CAB(1), SAB(1), CONSX(2) >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET),(CONST,CONSX) >*/
/*< DATA PI, TP, ETA/3.141592654D+0,6.283185308D+0,376.73/ >*/
/*< DATA CONSX/0.,-29.97922085D+0/ >*/
/*< PHX=- SIN( PHI) >*/
phx = -sin(*phi);
/*< PHY= COS( PHI) >*/
phy = cos(*phi);
/*< ROZ= COS( THET) >*/
roz = cos(*thet);
/*< ROZS= ROZ >*/
rozs = roz;
/*< THX= ROZ* PHY >*/
thx = roz * phy;
/*< THY=- ROZ* PHX >*/
thy = -roz * phx;
/*< THZ=- SIN( THET) >*/
thz = -sin(*thet);
/*< ROX=- THZ* PHY >*/
rox = -thz * phy;
/*< ROY= THZ* PHX >*/
roy = thz * phx;
/* LOOP FOR STRUCTURE IMAGE IF ANY */
/*< IF( N.EQ.0) GOTO 20 >*/
if (data_1.n == 0) {
goto L20;
}
/* CALCULATION OF REFLECTION COEFFECIENTS */
/*< DO 19 K=1, KSYMP >*/
i__1 = gnd_1.ksymp;
for (k = 1; k <= i__1; ++k) {
/*< IF( K.EQ.1) GOTO 4 >*/
if (k == 1) {
goto L4;
}
/* FOR PERFECT GROUND */
/*< IF( IPERF.NE.1) GOTO 1 >*/
if (gnd_1.iperf != 1) {
goto L1;
}
/*< RRV=-(1.,0.) >*/
rrv.r = -1., rrv.i = 0.;
/*< RRH=-(1.,0.) >*/
rrh.r = -1., rrh.i = 0.;
/* FOR INFINITE PLANAR GROUND */
/*< GOTO 2 >*/
goto L2;
/*< 1 ZRSIN= SQRT(1.- ZRATI* ZRATI* THZ* THZ) >*/
L1:
z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i *
gnd_1.zrati.i, z__5.i = gnd_1.zrati.r * gnd_1.zrati.i +
gnd_1.zrati.i * gnd_1.zrati.r;
z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
zrsin.r = z__1.r, zrsin.i = z__1.i;
/*< RRV=-( ROZ- ZRATI* ZRSIN)/( ROZ+ ZRATI* ZRSIN) >*/
z__4.r = gnd_1.zrati.r * zrsin.r - gnd_1.zrati.i * zrsin.i, z__4.i =
gnd_1.zrati.r * zrsin.i + gnd_1.zrati.i * zrsin.r;
z__3.r = roz - z__4.r, z__3.i = -z__4.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__6.r = gnd_1.zrati.r * zrsin.r - gnd_1.zrati.i * zrsin.i, z__6.i =
gnd_1.zrati.r * zrsin.i + gnd_1.zrati.i * zrsin.r;
z__5.r = roz + z__6.r, z__5.i = z__6.i;
z_div(&z__1, &z__2, &z__5);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRH=( ZRATI* ROZ- ZRSIN)/( ZRATI* ROZ+ ZRSIN) >*/
z__3.r = roz * gnd_1.zrati.r, z__3.i = roz * gnd_1.zrati.i;
z__2.r = z__3.r - zrsin.r, z__2.i = z__3.i - zrsin.i;
z__5.r = roz * gnd_1.zrati.r, z__5.i = roz * gnd_1.zrati.i;
z__4.r = z__5.r + zrsin.r, z__4.i = z__5.i + zrsin.i;
z_div(&z__1, &z__2, &z__4);
rrh.r = z__1.r, rrh.i = z__1.i;
/* FOR THE CLIFF PROBLEM, TWO REFLCTION COEFFICIENTS CALCULATED */
/*< 2 IF( IFAR.LE.1) GOTO 3 >*/
L2:
if (gnd_1.ifar <= 1) {
goto L3;
}
/*< RRV1= RRV >*/
rrv1.r = rrv.r, rrv1.i = rrv.i;
/*< RRH1= RRH >*/
rrh1.r = rrh.r, rrh1.i = rrh.i;
/*< TTHET= TAN( THET) >*/
tthet = tan(*thet);
/*< IF( IFAR.EQ.4) GOTO 3 >*/
if (gnd_1.ifar == 4) {
goto L3;
}
/*< ZRSIN= SQRT(1.- ZRATI2* ZRATI2* THZ* THZ) >*/
z__5.r = gnd_1.zrati2.r * gnd_1.zrati2.r - gnd_1.zrati2.i *
gnd_1.zrati2.i, z__5.i = gnd_1.zrati2.r * gnd_1.zrati2.i +
gnd_1.zrati2.i * gnd_1.zrati2.r;
z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
zrsin.r = z__1.r, zrsin.i = z__1.i;
/*< RRV2=-( ROZ- ZRATI2* ZRSIN)/( ROZ+ ZRATI2* ZRSIN) >*/
z__4.r = gnd_1.zrati2.r * zrsin.r - gnd_1.zrati2.i * zrsin.i, z__4.i =
gnd_1.zrati2.r * zrsin.i + gnd_1.zrati2.i * zrsin.r;
z__3.r = roz - z__4.r, z__3.i = -z__4.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__6.r = gnd_1.zrati2.r * zrsin.r - gnd_1.zrati2.i * zrsin.i, z__6.i =
gnd_1.zrati2.r * zrsin.i + gnd_1.zrati2.i * zrsin.r;
z__5.r = roz + z__6.r, z__5.i = z__6.i;
z_div(&z__1, &z__2, &z__5);
rrv2.r = z__1.r, rrv2.i = z__1.i;
/*< RRH2=( ZRATI2* ROZ- ZRSIN)/( ZRATI2* ROZ+ ZRSIN) >*/
z__3.r = roz * gnd_1.zrati2.r, z__3.i = roz * gnd_1.zrati2.i;
z__2.r = z__3.r - zrsin.r, z__2.i = z__3.i - zrsin.i;
z__5.r = roz * gnd_1.zrati2.r, z__5.i = roz * gnd_1.zrati2.i;
z__4.r = z__5.r + zrsin.r, z__4.i = z__5.i + zrsin.i;
z_div(&z__1, &z__2, &z__4);
rrh2.r = z__1.r, rrh2.i = z__1.i;
/*< DARG=- TP*2.* CH* ROZ >*/
d__2 = -tp * 2.;
d__1 = d__2 * gnd_1.ch;
darg = d__1 * roz;
/*< 3 ROZ=- ROZ >*/
L3:
roz = -roz;
/*< CCX= CIX >*/
ccx.r = cix.r, ccx.i = cix.i;
/*< CCY= CIY >*/
ccy.r = ciy.r, ccy.i = ciy.i;
/*< CCZ= CIZ >*/
ccz.r = ciz.r, ccz.i = ciz.i;
/*< 4 CIX=(0.,0.) >*/
L4:
cix.r = 0., cix.i = 0.;
/*< CIY=(0.,0.) >*/
ciy.r = 0., ciy.i = 0.;
/* LOOP OVER STRUCTURE SEGMENTS */
/*< CIZ=(0.,0.) >*/
ciz.r = 0., ciz.i = 0.;
/*< DO 17 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< OMEGA=-( ROX* CAB( I)+ ROY* SAB( I)+ ROZ* SALP( I)) >*/
d__1 = rox * cab[i - 1] + roy * sab[i - 1];
omega = -(d__1 + roz * angl_1.salp[i - 1]);
/*< EL= PI* SI( I) >*/
el = pi * data_1.si[i - 1];
/*< SILL= OMEGA* EL >*/
sill = omega * el;
/*< TOP= EL+ SILL >*/
top = el + sill;
/*< BOT= EL- SILL >*/
bot = el - sill;
/*< IF( ABS( OMEGA).LT.1.D-7) GOTO 5 >*/
if (abs(omega) < 1e-7) {
goto L5;
}
/*< A=2.* SIN( SILL)/ OMEGA >*/
a = sin(sill) * 2. / omega;
/*< GOTO 6 >*/
goto L6;
/*< 5 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL >*/
L5:
d__2 = omega * omega;
d__1 = d__2 * el;
a = (2. - d__1 * el / 3.) * el;
/*< 6 IF( ABS( TOP).LT.1.D-7) GOTO 7 >*/
L6:
if (abs(top) < 1e-7) {
goto L7;
}
/*< TOO= SIN( TOP)/ TOP >*/
too = sin(top) / top;
/*< GOTO 8 >*/
goto L8;
/*< 7 TOO=1.- TOP* TOP/6. >*/
L7:
too = 1. - top * top / 6.;
/*< 8 IF( ABS( BOT).LT.1.D-7) GOTO 9 >*/
L8:
if (abs(bot) < 1e-7) {
goto L9;
}
/*< BOO= SIN( BOT)/ BOT >*/
boo = sin(bot) / bot;
/*< GOTO 10 >*/
goto L10;
/*< 9 BOO=1.- BOT* BOT/6. >*/
L9:
boo = 1. - bot * bot / 6.;
/*< 10 B= EL*( BOO- TOO) >*/
L10:
b = el * (boo - too);
/*< C= EL*( BOO+ TOO) >*/
c = el * (boo + too);
/*< RR= A* AIR( I)+ B* BII( I)+ C* CIR( I) >*/
d__1 = a * crnt_1.air[i - 1] + b * crnt_1.bii[i - 1];
rr = d__1 + c * crnt_1.cir[i - 1];
/*< RI= A* AII( I)- B* BIR( I)+ C* CII( I) >*/
ri = a * crnt_1.aii[i - 1] - b * crnt_1.bir[i - 1] + c *
crnt_1.cii[i - 1];
/*< ARG= TP*( X( I)* ROX+ Y( I)* ROY+ Z( I)* ROZ) >*/
d__1 = data_1.x[i - 1] * rox + data_1.y[i - 1] * roy;
arg = tp * (d__1 + data_1.z[i - 1] * roz);
/*< IF( K.EQ.2.AND. IFAR.GE.2) GOTO 11 >*/
if (k == 2 && gnd_1.ifar >= 2) {
goto L11;
}
/* SUMMATION FOR FAR FIELD INTEGRAL */
/*< EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI) >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__2.r = d__1, z__2.i = d__2;
z__3.r = rr, z__3.i = ri;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r *
z__3.i + z__2.i * z__3.r;
exa.r = z__1.r, exa.i = z__1.i;
/*< CIX= CIX+ EXA* CAB( I) >*/
i__3 = i - 1;
z__2.r = cab[i__3] * exa.r, z__2.i = cab[i__3] * exa.i;
z__1.r = cix.r + z__2.r, z__1.i = cix.i + z__2.i;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CIY+ EXA* SAB( I) >*/
i__3 = i - 1;
z__2.r = sab[i__3] * exa.r, z__2.i = sab[i__3] * exa.i;
z__1.r = ciy.r + z__2.r, z__1.i = ciy.i + z__2.i;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< CIZ= CIZ+ EXA* SALP( I) >*/
i__3 = i - 1;
z__2.r = angl_1.salp[i__3] * exa.r, z__2.i = angl_1.salp[i__3] *
exa.i;
z__1.r = ciz.r + z__2.r, z__1.i = ciz.i + z__2.i;
ciz.r = z__1.r, ciz.i = z__1.i;
/* CALCULATION OF IMAGE CONTRIBUTION IN CLIFF AND GROUND SCREE
N */
/* PROBLEMS. */
/*< GOTO 17 >*/
goto L17;
/* SPECULAR POINT DISTANCE */
/*< 11 DR= Z( I)* TTHET >*/
L11:
dr = data_1.z[i - 1] * tthet;
/*< D= DR* PHY+ X( I) >*/
d = dr * phy + data_1.x[i - 1];
/*< IF( IFAR.EQ.2) GOTO 13 >*/
if (gnd_1.ifar == 2) {
goto L13;
}
/*< D= SQRT( D* D+( Y( I)- DR* PHX)**2) >*/
/* Computing 2nd power */
d__1 = data_1.y[i - 1] - dr * phx;
d = sqrt(d * d + d__1 * d__1);
/*< IF( IFAR.EQ.3) GOTO 13 >*/
if (gnd_1.ifar == 3) {
goto L13;
}
/* RADIAL WIRE GROUND SCREEN REFLECTION COEFFICIENT */
/*< IF(( SCRWL- D).LT.0.) GOTO 12 >*/
if (gnd_1.scrwl - d < 0.) {
goto L12;
}
/*< D= D+ T2 >*/
d += gnd_1.t2;
/*< ZSCRN= T1* D* LOG( D/ T2) >*/
z__2.r = d * gnd_1.t1.r, z__2.i = d * gnd_1.t1.i;
d__1 = log(d / gnd_1.t2);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
zscrn.r = z__1.r, zscrn.i = z__1.i;
/*< ZSCRN=( ZSCRN* ZRATI)/( ETA* ZRATI+ ZSCRN) >*/
z__2.r = zscrn.r * gnd_1.zrati.r - zscrn.i * gnd_1.zrati.i,
z__2.i = zscrn.r * gnd_1.zrati.i + zscrn.i *
gnd_1.zrati.r;
z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
z__3.r = z__4.r + zscrn.r, z__3.i = z__4.i + zscrn.i;
z_div(&z__1, &z__2, &z__3);
zscrn.r = z__1.r, zscrn.i = z__1.i;
/*< ZRSIN= SQRT(1.- ZSCRN* ZSCRN* THZ* THZ) >*/
z__5.r = zscrn.r * zscrn.r - zscrn.i * zscrn.i, z__5.i = zscrn.r *
zscrn.i + zscrn.i * zscrn.r;
z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
zrsin.r = z__1.r, zrsin.i = z__1.i;
/*< RRV=( ROZ+ ZSCRN* ZRSIN)/(- ROZ+ ZSCRN* ZRSIN) >*/
z__3.r = zscrn.r * zrsin.r - zscrn.i * zrsin.i, z__3.i = zscrn.r *
zrsin.i + zscrn.i * zrsin.r;
z__2.r = roz + z__3.r, z__2.i = z__3.i;
d__1 = -roz;
z__5.r = zscrn.r * zrsin.r - zscrn.i * zrsin.i, z__5.i = zscrn.r *
zrsin.i + zscrn.i * zrsin.r;
z__4.r = d__1 + z__5.r, z__4.i = z__5.i;
z_div(&z__1, &z__2, &z__4);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRH=( ZSCRN* ROZ+ ZRSIN)/( ZSCRN* ROZ- ZRSIN) >*/
z__3.r = roz * zscrn.r, z__3.i = roz * zscrn.i;
z__2.r = z__3.r + zrsin.r, z__2.i = z__3.i + zrsin.i;
z__5.r = roz * zscrn.r, z__5.i = roz * zscrn.i;
z__4.r = z__5.r - zrsin.r, z__4.i = z__5.i - zrsin.i;
z_div(&z__1, &z__2, &z__4);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< GOTO 16 >*/
goto L16;
/*< 12 IF( IFAR.EQ.4) GOTO 14 >*/
L12:
if (gnd_1.ifar == 4) {
goto L14;
}
/*< IF( IFAR.EQ.5) D= DR* PHY+ X( I) >*/
if (gnd_1.ifar == 5) {
d = dr * phy + data_1.x[i - 1];
}
/*< 13 IF(( CL- D).LE.0.) GOTO 15 >*/
L13:
if (gnd_1.cl - d <= 0.) {
goto L15;
}
/*< 14 RRV= RRV1 >*/
L14:
rrv.r = rrv1.r, rrv.i = rrv1.i;
/*< RRH= RRH1 >*/
rrh.r = rrh1.r, rrh.i = rrh1.i;
/*< GOTO 16 >*/
goto L16;
/*< 15 RRV= RRV2 >*/
L15:
rrv.r = rrv2.r, rrv.i = rrv2.i;
/*< RRH= RRH2 >*/
rrh.r = rrh2.r, rrh.i = rrh2.i;
/*< ARG= ARG+ DARG >*/
arg += darg;
/* CONTRIBUTION OF EACH IMAGE SEGMENT MODIFIED BY REFLECTION C
OEF. , */
/* FOR CLIFF AND GROUND SCREEN PROBLEMS */
/*< 16 EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI) >*/
L16:
d__1 = cos(arg);
d__2 = sin(arg);
z__2.r = d__1, z__2.i = d__2;
z__3.r = rr, z__3.i = ri;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r *
z__3.i + z__2.i * z__3.r;
exa.r = z__1.r, exa.i = z__1.i;
/*< TIX= EXA* CAB( I) >*/
i__3 = i - 1;
z__1.r = cab[i__3] * exa.r, z__1.i = cab[i__3] * exa.i;
tix.r = z__1.r, tix.i = z__1.i;
/*< TIY= EXA* SAB( I) >*/
i__3 = i - 1;
z__1.r = sab[i__3] * exa.r, z__1.i = sab[i__3] * exa.i;
tiy.r = z__1.r, tiy.i = z__1.i;
/*< TIZ= EXA* SALP( I) >*/
i__3 = i - 1;
z__1.r = angl_1.salp[i__3] * exa.r, z__1.i = angl_1.salp[i__3] *
exa.i;
tiz.r = z__1.r, tiz.i = z__1.i;
/*< CDP=( TIX* PHX+ TIY* PHY)*( RRH- RRV) >*/
z__3.r = phx * tix.r, z__3.i = phx * tix.i;
z__4.r = phy * tiy.r, z__4.i = phy * tiy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r *
z__5.i + z__2.i * z__5.r;
cdp.r = z__1.r, cdp.i = z__1.i;
/*< CIX= CIX+ TIX* RRV+ CDP* PHX >*/
z__3.r = tix.r * rrv.r - tix.i * rrv.i, z__3.i = tix.r * rrv.i +
tix.i * rrv.r;
z__2.r = cix.r + z__3.r, z__2.i = cix.i + z__3.i;
z__4.r = phx * cdp.r, z__4.i = phx * cdp.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CIY+ TIY* RRV+ CDP* PHY >*/
z__3.r = tiy.r * rrv.r - tiy.i * rrv.i, z__3.i = tiy.r * rrv.i +
tiy.i * rrv.r;
z__2.r = ciy.r + z__3.r, z__2.i = ciy.i + z__3.i;
z__4.r = phy * cdp.r, z__4.i = phy * cdp.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< CIZ= CIZ- TIZ* RRV >*/
z__2.r = tiz.r * rrv.r - tiz.i * rrv.i, z__2.i = tiz.r * rrv.i +
tiz.i * rrv.r;
z__1.r = ciz.r - z__2.r, z__1.i = ciz.i - z__2.i;
ciz.r = z__1.r, ciz.i = z__1.i;
/*< 17 CONTINUE >*/
L17:
;
}
/*< IF( K.EQ.1) GOTO 19 >*/
if (k == 1) {
goto L19;
}
/* CALCULATION OF CONTRIBUTION OF STRUCTURE IMAGE FOR INFINITE GRO
UND */
/*< IF( IFAR.GE.2) GOTO 18 >*/
if (gnd_1.ifar >= 2) {
goto L18;
}
/*< CDP=( CIX* PHX+ CIY* PHY)*( RRH- RRV) >*/
z__3.r = phx * cix.r, z__3.i = phx * cix.i;
z__4.r = phy * ciy.r, z__4.i = phy * ciy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i
+ z__2.i * z__5.r;
cdp.r = z__1.r, cdp.i = z__1.i;
/*< CIX= CCX+ CIX* RRV+ CDP* PHX >*/
z__3.r = cix.r * rrv.r - cix.i * rrv.i, z__3.i = cix.r * rrv.i +
cix.i * rrv.r;
z__2.r = ccx.r + z__3.r, z__2.i = ccx.i + z__3.i;
z__4.r = phx * cdp.r, z__4.i = phx * cdp.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CCY+ CIY* RRV+ CDP* PHY >*/
z__3.r = ciy.r * rrv.r - ciy.i * rrv.i, z__3.i = ciy.r * rrv.i +
ciy.i * rrv.r;
z__2.r = ccy.r + z__3.r, z__2.i = ccy.i + z__3.i;
z__4.r = phy * cdp.r, z__4.i = phy * cdp.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< CIZ= CCZ- CIZ* RRV >*/
z__2.r = ciz.r * rrv.r - ciz.i * rrv.i, z__2.i = ciz.r * rrv.i +
ciz.i * rrv.r;
z__1.r = ccz.r - z__2.r, z__1.i = ccz.i - z__2.i;
ciz.r = z__1.r, ciz.i = z__1.i;
/*< GOTO 19 >*/
goto L19;
/*< 18 CIX= CIX+ CCX >*/
L18:
z__1.r = cix.r + ccx.r, z__1.i = cix.i + ccx.i;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CIY+ CCY >*/
z__1.r = ciy.r + ccy.r, z__1.i = ciy.i + ccy.i;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< CIZ= CIZ+ CCZ >*/
z__1.r = ciz.r + ccz.r, z__1.i = ciz.i + ccz.i;
ciz.r = z__1.r, ciz.i = z__1.i;
/*< 19 CONTINUE >*/
L19:
;
}
/*< IF( M.GT.0) GOTO 21 >*/
if (data_1.m > 0) {
goto L21;
}
/*< ETH=( CIX* THX+ CIY* THY+ CIZ* THZ)* CONST >*/
z__4.r = thx * cix.r, z__4.i = thx * cix.i;
z__5.r = thy * ciy.r, z__5.i = thy * ciy.i;
z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i;
z__6.r = thz * ciz.r, z__6.i = thz * ciz.i;
z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i;
z__1.r = z__2.r * const_->r - z__2.i * const_->i, z__1.i = z__2.r *
const_->i + z__2.i * const_->r;
eth->r = z__1.r, eth->i = z__1.i;
/*< EPH=( CIX* PHX+ CIY* PHY)* CONST >*/
z__3.r = phx * cix.r, z__3.i = phx * cix.i;
z__4.r = phy * ciy.r, z__4.i = phy * ciy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = z__2.r * const_->r - z__2.i * const_->i, z__1.i = z__2.r *
const_->i + z__2.i * const_->r;
eph->r = z__1.r, eph->i = z__1.i;
/*< RETURN >*/
return 0;
/*< 20 CIX=(0.,0.) >*/
L20:
cix.r = 0., cix.i = 0.;
/*< CIY=(0.,0.) >*/
ciy.r = 0., ciy.i = 0.;
/*< CIZ=(0.,0.) >*/
ciz.r = 0., ciz.i = 0.;
/* ELECTRIC FIELD COMPONENTS */
/*< 21 ROZ= ROZS >*/
L21:
roz = rozs;
/*< RFL=-1. >*/
rfl = -1.;
/*< DO 25 IP=1, KSYMP >*/
i__1 = gnd_1.ksymp;
for (ip = 1; ip <= i__1; ++ip) {
/*< RFL=- RFL >*/
rfl = -rfl;
/*< RRZ= ROZ* RFL >*/
rrz = roz * rfl;
/*< CALL FFLDS( ROX, ROY, RRZ, CUR( N+1), GX, GY, GZ) >*/
fflds_(&rox, &roy, &rrz, &crnt_1.cur[data_1.n], &gx, &gy, &gz);
/*< IF( IP.EQ.2) GOTO 22 >*/
if (ip == 2) {
goto L22;
}
/*< EX= GX >*/
ex.r = gx.r, ex.i = gx.i;
/*< EY= GY >*/
ey.r = gy.r, ey.i = gy.i;
/*< EZ= GZ >*/
ez.r = gz.r, ez.i = gz.i;
/*< GOTO 25 >*/
goto L25;
/*< 22 IF( IPERF.NE.1) GOTO 23 >*/
L22:
if (gnd_1.iperf != 1) {
goto L23;
}
/*< GX=- GX >*/
z__1.r = -gx.r, z__1.i = -gx.i;
gx.r = z__1.r, gx.i = z__1.i;
/*< GY=- GY >*/
z__1.r = -gy.r, z__1.i = -gy.i;
gy.r = z__1.r, gy.i = z__1.i;
/*< GZ=- GZ >*/
z__1.r = -gz.r, z__1.i = -gz.i;
gz.r = z__1.r, gz.i = z__1.i;
/*< GOTO 24 >*/
goto L24;
/*< 23 RRV= SQRT(1.- ZRATI* ZRATI* THZ* THZ) >*/
L23:
z__5.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i *
gnd_1.zrati.i, z__5.i = gnd_1.zrati.r * gnd_1.zrati.i +
gnd_1.zrati.i * gnd_1.zrati.r;
z__4.r = thz * z__5.r, z__4.i = thz * z__5.i;
z__3.r = thz * z__4.r, z__3.i = thz * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRH= ZRATI* ROZ >*/
z__1.r = roz * gnd_1.zrati.r, z__1.i = roz * gnd_1.zrati.i;
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRH=( RRH- RRV)/( RRH+ RRV) >*/
z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
z_div(&z__1, &z__2, &z__3);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRV= ZRATI* RRV >*/
z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i =
gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRV=-( ROZ- RRV)/( ROZ+ RRV) >*/
z__3.r = roz - rrv.r, z__3.i = -rrv.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__4.r = roz + rrv.r, z__4.i = rrv.i;
z_div(&z__1, &z__2, &z__4);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< ETH=( GX* PHX+ GY* PHY)*( RRH- RRV) >*/
z__3.r = phx * gx.r, z__3.i = phx * gx.i;
z__4.r = phy * gy.r, z__4.i = phy * gy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i
+ z__2.i * z__5.r;
eth->r = z__1.r, eth->i = z__1.i;
/*< GX= GX* RRV+ ETH* PHX >*/
z__2.r = gx.r * rrv.r - gx.i * rrv.i, z__2.i = gx.r * rrv.i + gx.i *
rrv.r;
z__3.r = phx * eth->r, z__3.i = phx * eth->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
gx.r = z__1.r, gx.i = z__1.i;
/*< GY= GY* RRV+ ETH* PHY >*/
z__2.r = gy.r * rrv.r - gy.i * rrv.i, z__2.i = gy.r * rrv.i + gy.i *
rrv.r;
z__3.r = phy * eth->r, z__3.i = phy * eth->i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
gy.r = z__1.r, gy.i = z__1.i;
/*< GZ= GZ* RRV >*/
z__1.r = gz.r * rrv.r - gz.i * rrv.i, z__1.i = gz.r * rrv.i + gz.i *
rrv.r;
gz.r = z__1.r, gz.i = z__1.i;
/*< 24 EX= EX+ GX >*/
L24:
z__1.r = ex.r + gx.r, z__1.i = ex.i + gx.i;
ex.r = z__1.r, ex.i = z__1.i;
/*< EY= EY+ GY >*/
z__1.r = ey.r + gy.r, z__1.i = ey.i + gy.i;
ey.r = z__1.r, ey.i = z__1.i;
/*< EZ= EZ- GZ >*/
z__1.r = ez.r - gz.r, z__1.i = ez.i - gz.i;
ez.r = z__1.r, ez.i = z__1.i;
/*< 25 CONTINUE >*/
L25:
;
}
/*< EX= EX+ CIX* CONST >*/
z__2.r = cix.r * const_->r - cix.i * const_->i, z__2.i = cix.r *
const_->i + cix.i * const_->r;
z__1.r = ex.r + z__2.r, z__1.i = ex.i + z__2.i;
ex.r = z__1.r, ex.i = z__1.i;
/*< EY= EY+ CIY* CONST >*/
z__2.r = ciy.r * const_->r - ciy.i * const_->i, z__2.i = ciy.r *
const_->i + ciy.i * const_->r;
z__1.r = ey.r + z__2.r, z__1.i = ey.i + z__2.i;
ey.r = z__1.r, ey.i = z__1.i;
/*< EZ= EZ+ CIZ* CONST >*/
z__2.r = ciz.r * const_->r - ciz.i * const_->i, z__2.i = ciz.r *
const_->i + ciz.i * const_->r;
z__1.r = ez.r + z__2.r, z__1.i = ez.i + z__2.i;
ez.r = z__1.r, ez.i = z__1.i;
/*< ETH= EX* THX+ EY* THY+ EZ* THZ >*/
z__3.r = thx * ex.r, z__3.i = thx * ex.i;
z__4.r = thy * ey.r, z__4.i = thy * ey.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = thz * ez.r, z__5.i = thz * ez.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
eth->r = z__1.r, eth->i = z__1.i;
/*< EPH= EX* PHX+ EY* PHY >*/
z__2.r = phx * ex.r, z__2.i = phx * ex.i;
z__3.r = phy * ey.r, z__3.i = phy * ey.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
eph->r = z__1.r, eph->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* ffld_ */
#undef sab
#undef cab
#undef consx
#undef const_
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE FFLDS( ROX, ROY, ROZ, SCUR, EX, EY, EZ) >*/
/* Subroutine */ int fflds_(rox, roy, roz, scur, ex, ey, ez)
doublereal *rox, *roy, *roz;
doublecomplex *scur, *ex, *ey, *ez;
{
/* Initialized data */
static doublereal tpi = 6.283185308;
static struct {
doublereal e_1[3];
} equiv_4 = { 0., 188.365, 0. };
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double cos(), sin();
/* Local variables */
#define cons ((doublecomplex *)&equiv_4)
static integer i, j, k;
#define s ((doublereal *)&data_1 + 2400)
#define consx ((doublereal *)&equiv_4)
static doublecomplex ct;
#define xs ((doublereal *)&data_1)
#define ys ((doublereal *)&data_1 + 600)
#define zs ((doublereal *)&data_1 + 1200)
static doublereal arg;
/* *** */
/* CALCULATES THE XYZ COMPONENTS OF THE ELECTRIC FIELD DUE TO */
/* SURFACE CURRENTS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX CT, CONS, SCUR, EX, EY, EZ >*/
/*< >*/
/*< DIMENSION XS(1), YS(1), ZS(1), S(1), SCUR(1), CONSX(2) >*/
/*< EQUIVALENCE(XS,X),(YS,Y),(ZS,Z),(S,BI),(CONS,CONSX) >*/
/*< DATA TPI/6.283185308D+0/, CONSX/0.,188.365/ >*/
/* Parameter adjustments */
--scur;
/* Function Body */
/*< EX=(0.,0.) >*/
ex->r = 0., ex->i = 0.;
/*< EY=(0.,0.) >*/
ey->r = 0., ey->i = 0.;
/*< EZ=(0.,0.) >*/
ez->r = 0., ez->i = 0.;
/*< I= LD+1 >*/
i = data_1.ld + 1;
/*< DO 1 J=1, M >*/
i__1 = data_1.m;
for (j = 1; j <= i__1; ++j) {
/*< I= I-1 >*/
--i;
/*< ARG= TPI*( ROX* XS( I)+ ROY* YS( I)+ ROZ* ZS( I)) >*/
d__1 = *rox * xs[i - 1] + *roy * ys[i - 1];
arg = tpi * (d__1 + *roz * zs[i - 1]);
/*< CT= CMPLX( COS( ARG)* S( I), SIN( ARG)* S( I)) >*/
d__1 = cos(arg) * s[i - 1];
d__2 = sin(arg) * s[i - 1];
z__1.r = d__1, z__1.i = d__2;
ct.r = z__1.r, ct.i = z__1.i;
/*< K=3* J >*/
k = j * 3;
/*< EX= EX+ SCUR( K-2)* CT >*/
i__2 = k - 2;
z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
i__2].r * ct.i + scur[i__2].i * ct.r;
z__1.r = ex->r + z__2.r, z__1.i = ex->i + z__2.i;
ex->r = z__1.r, ex->i = z__1.i;
/*< EY= EY+ SCUR( K-1)* CT >*/
i__2 = k - 1;
z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
i__2].r * ct.i + scur[i__2].i * ct.r;
z__1.r = ey->r + z__2.r, z__1.i = ey->i + z__2.i;
ey->r = z__1.r, ey->i = z__1.i;
/*< EZ= EZ+ SCUR( K)* CT >*/
i__2 = k;
z__2.r = scur[i__2].r * ct.r - scur[i__2].i * ct.i, z__2.i = scur[
i__2].r * ct.i + scur[i__2].i * ct.r;
z__1.r = ez->r + z__2.r, z__1.i = ez->i + z__2.i;
ez->r = z__1.r, ez->i = z__1.i;
/*< 1 CONTINUE >*/
/* L1: */
}
/*< CT= ROX* EX+ ROY* EY+ ROZ* EZ >*/
z__3.r = *rox * ex->r, z__3.i = *rox * ex->i;
z__4.r = *roy * ey->r, z__4.i = *roy * ey->i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = *roz * ez->r, z__5.i = *roz * ez->i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ct.r = z__1.r, ct.i = z__1.i;
/*< EX= CONS*( CT* ROX- EX) >*/
z__3.r = *rox * ct.r, z__3.i = *rox * ct.i;
z__2.r = z__3.r - ex->r, z__2.i = z__3.i - ex->i;
z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i +
cons->i * z__2.r;
ex->r = z__1.r, ex->i = z__1.i;
/*< EY= CONS*( CT* ROY- EY) >*/
z__3.r = *roy * ct.r, z__3.i = *roy * ct.i;
z__2.r = z__3.r - ey->r, z__2.i = z__3.i - ey->i;
z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i +
cons->i * z__2.r;
ey->r = z__1.r, ey->i = z__1.i;
/*< EZ= CONS*( CT* ROZ- EZ) >*/
z__3.r = *roz * ct.r, z__3.i = *roz * ct.i;
z__2.r = z__3.r - ez->r, z__2.i = z__3.i - ez->i;
z__1.r = cons->r * z__2.r - cons->i * z__2.i, z__1.i = cons->r * z__2.i +
cons->i * z__2.r;
ez->r = z__1.r, ez->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* fflds_ */
#undef zs
#undef ys
#undef xs
#undef consx
#undef s
#undef cons
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GF( ZK, CO, SI) >*/
/* Subroutine */ int gf_(zk, co, si)
doublereal *zk, *co, *si;
{
/* Builtin functions */
double sqrt(), sin(), cos();
/* Local variables */
static doublereal rk, zdk, rks;
/* *** */
/* GF COMPUTES THE INTEGRAND EXP(JKR)/(KR) FOR NUMERICAL INTEGRATION.
*/
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMMON /TMI/ ZPK, RKB2, IJ >*/
/*< ZDK= ZK- ZPK >*/
zdk = *zk - tmi_2.zpk;
/*< RK= SQRT( RKB2+ ZDK* ZDK) >*/
rk = sqrt(tmi_2.rkb2 + zdk * zdk);
/*< SI= SIN( RK)/ RK >*/
*si = sin(rk) / rk;
/*< IF( IJ) 1,2,1 >*/
if (tmi_2.ij != 0) {
goto L1;
} else {
goto L2;
}
/*< 1 CO= COS( RK)/ RK >*/
L1:
*co = cos(rk) / rk;
/*< RETURN >*/
return 0;
/*< 2 IF( RK.LT..2) GOTO 3 >*/
L2:
if (rk < .2) {
goto L3;
}
/*< CO=( COS( RK)-1.)/ RK >*/
*co = (cos(rk) - 1.) / rk;
/*< RETURN >*/
return 0;
/*< 3 RKS= RK* RK >*/
L3:
rks = rk * rk;
/*< CO=((-1.38888889D-3* RKS+4.16666667D-2)* RKS-.5)* RK >*/
*co = ((rks * -.00138888889 + .0416666667) * rks - .5) * rk;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GFIL( IPRT) >*/
/* Subroutine */ int gfil_(iprt)
integer *iprt;
{
/* Initialized data */
static integer igfl = 20;
/* Format strings */
static char fmt_16[] = "(////)";
static char fmt_14[] = "(5x,\002****************************************\
**********\002,\002**********************************\002)";
static char fmt_17[] = "(5x,\002**\002,80x,\002**\002)";
static char fmt_18[] = "(5x,\002** NUMERICAL GREEN S FUNCTION\002,53x\
,\002**\002,/,5x,\002** NO\002,\002. SEGMENTS =\002,i4,10x,\002NO. PATCHES \
=\002,i4,34x,\002**\002)";
static char fmt_19[] = "(5x,\002** NO. SYMMETRIC SECTIONS =\002,i4,51x\
,\002**\002)";
static char fmt_20[] = "(5x,\002** N.G.F. MATRIX - CORE STORAGE =\002,i\
7,\002 COMPLEX NU\002,\002MBERS, CASE\002,i2,16x,\002**\002)";
static char fmt_21[] = "(5x,\002**\002,19x,\002MATRIX SIZE =\002,i7,\002\
COMPLEX NUMBERS\002,25x,\002**\002)";
static char fmt_22[] = "(5x,\002** FREQUENCY =\002,1p,e12.5,\002 MHZ.\
\002,51x,\002**\002)";
static char fmt_23[] = "(5x,\002** PERFECT GROUND\002,65x,\002**\002)";
static char fmt_27[] = "(5x,\002** FINITE GROUND. REFLECTION COEFFICIEN\
T APPROXIMAT\002,\002ION\002,27x,\002**\002)";
static char fmt_28[] = "(5x,\002** FINITE GROUND. SOMMERFELD SOLUTIO\
N\002,44x,\002**\002)";
static char fmt_24[] = "(5x,\002** GROUND PARAMETERS - DIELECTRIC CONSTA\
NT =\002,1p,e12.5,26x,\002**\002,/,5x,\002**\002,21x,\002CONDUCTIVITY =\002,\
e12.5,\002 MHOS/M.\002,25x,\002**\002)";
static char fmt_15[] = "(5x,\002** \002,19a4,\002 **\002)";
static char fmt_25[] = "(39x,\002NUMERICAL GREEN S FUNCTION DATA\002,/,4\
1x,\002COORDINATES\002,\002 OF SEGMENT ENDS\002,/,51x,\002(METERS)\002,/,5x\
,\002SEG.\002,11x,\002- - - END ON'E - - -\002,26x,\002- - - END TWO - - \
-\002,/,6x,\002NO.\002,6x,\002X\002,14x,\002Y\002,14x,\002Z\002,14x,\002X\
\002,14x,\002Y\002,14x,\002Z\002)";
static char fmt_26[] = "(1x,i7,1p,6e15.6)";
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
alist al__1;
/* Builtin functions */
integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue(), s_wsfe(
), e_wsfe(), do_fio();
/* Local variables */
static integer npeq, iout, i, j, k;
static doublereal dx, xi, yi, zi;
extern /* Subroutine */ int blckin_(), blckot_();
static integer neq, iop, nop, nbl2;
/* Fortran I/O blocks */
static cilist io___900 = { 0, 0, 0, 0, 0 };
static cilist io___901 = { 0, 0, 0, 0, 0 };
static cilist io___903 = { 0, 0, 0, 0, 0 };
static cilist io___904 = { 0, 0, 0, 0, 0 };
static cilist io___905 = { 0, 0, 0, 0, 0 };
static cilist io___906 = { 0, 0, 0, 0, 0 };
static cilist io___907 = { 0, 0, 0, 0, 0 };
static cilist io___913 = { 0, 0, 0, 0, 0 };
static cilist io___914 = { 0, 0, 0, 0, 0 };
static cilist io___915 = { 0, 0, 0, 0, 0 };
static cilist io___916 = { 0, 0, 0, 0, 0 };
static cilist io___917 = { 0, 0, 0, 0, 0 };
static cilist io___918 = { 0, 0, 0, 0, 0 };
static cilist io___919 = { 0, 0, 0, 0, 0 };
static cilist io___923 = { 0, 0, 0, 0, 0 };
static cilist io___924 = { 0, 0, 0, 0, 0 };
static cilist io___926 = { 0, 0, 0, 0, 0 };
static cilist io___928 = { 0, 0, 0, 0, 0 };
static cilist io___929 = { 0, 13, 0, 0, 0 };
static cilist io___932 = { 0, 6, 0, fmt_16, 0 };
static cilist io___933 = { 0, 6, 0, fmt_14, 0 };
static cilist io___934 = { 0, 6, 0, fmt_14, 0 };
static cilist io___935 = { 0, 6, 0, fmt_17, 0 };
static cilist io___936 = { 0, 6, 0, fmt_18, 0 };
static cilist io___937 = { 0, 6, 0, fmt_19, 0 };
static cilist io___938 = { 0, 6, 0, fmt_20, 0 };
static cilist io___939 = { 0, 6, 0, fmt_21, 0 };
static cilist io___940 = { 0, 6, 0, fmt_22, 0 };
static cilist io___941 = { 0, 6, 0, fmt_23, 0 };
static cilist io___942 = { 0, 6, 0, fmt_27, 0 };
static cilist io___943 = { 0, 6, 0, fmt_28, 0 };
static cilist io___944 = { 0, 6, 0, fmt_24, 0 };
static cilist io___945 = { 0, 6, 0, fmt_17, 0 };
static cilist io___946 = { 0, 6, 0, fmt_15, 0 };
static cilist io___947 = { 0, 6, 0, fmt_17, 0 };
static cilist io___948 = { 0, 6, 0, fmt_14, 0 };
static cilist io___949 = { 0, 6, 0, fmt_14, 0 };
static cilist io___950 = { 0, 6, 0, fmt_16, 0 };
static cilist io___951 = { 0, 6, 0, fmt_25, 0 };
static cilist io___952 = { 0, 6, 0, fmt_26, 0 };
/* *** */
/* GFIL READS THE N.G.F. FILE */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /CMB/ CM(90000) >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /SMAT/ SSX(16,16) >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< COMMON /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
/*< DATA IGFL/20/ >*/
/*< REWIND IGFL >*/
al__1.aerr = 0;
al__1.aunit = igfl;
f_rew(&al__1);
/*< >*/
io___900.ciunit = igfl;
s_rsue(&io___900);
do_uio(&c__1, (char *)&data_1.n1, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.m1, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.ksymp, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.iperf, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&zload_1.nlodf, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&save_1.kcom, (ftnlen)sizeof(integer));
e_rsue();
/*< N= N1 >*/
data_1.n = data_1.n1;
/*< M= M1 >*/
data_1.m = data_1.m1;
/*< N2= N1+1 >*/
data_1.n2 = data_1.n1 + 1;
/*< M2= M1+1 >*/
data_1.m2 = data_1.m1 + 1;
/* READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS */
/*< IF( N1.EQ.0) GOTO 2 >*/
if (data_1.n1 == 0) {
goto L2;
}
/*< >*/
io___901.ciunit = igfl;
s_rsue(&io___901);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n1;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.n1;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< >*/
io___903.ciunit = igfl;
s_rsue(&io___903);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n1;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.n1;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< READ( IGFL) ( BET( I), I=1, N1),( SALP( I), I=1, N1) >*/
io___904.ciunit = igfl;
s_rsue(&io___904);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n1;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
;
}
e_rsue();
/*< READ( IGFL) ( ICON1( I), I=1, N1),( ICON2( I), I=1, N1) >*/
io___905.ciunit = igfl;
s_rsue(&io___905);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
}
i__2 = data_1.n1;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
}
e_rsue();
/*< READ( IGFL) ( ITAG( I), I=1, N1) >*/
io___906.ciunit = igfl;
s_rsue(&io___906);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
}
e_rsue();
/*< IF( NLODF.NE.0) READ( IGFL) ( ZARRAY( I), I=1, N1) >*/
if (zload_1.nlodf != 0) {
io___907.ciunit = igfl;
s_rsue(&io___907);
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__2, (char *)&zload_1.zarray[i - 1], (ftnlen)sizeof(
doublereal));
}
e_rsue();
}
/*< DO 1 I=1, N1 >*/
i__1 = data_1.n1;
for (i = 1; i <= i__1; ++i) {
/*< XI= X( I)* WLAM >*/
xi = data_1.x[i - 1] * data_1.wlam;
/*< YI= Y( I)* WLAM >*/
yi = data_1.y[i - 1] * data_1.wlam;
/*< ZI= Z( I)* WLAM >*/
zi = data_1.z[i - 1] * data_1.wlam;
/*< DX= SI( I)*.5* WLAM >*/
d__1 = data_1.si[i - 1] * .5;
dx = d__1 * data_1.wlam;
/*< X( I)= XI- ALP( I)* DX >*/
data_1.x[i - 1] = xi - data_1.alp[i - 1] * dx;
/*< Y( I)= YI- BET( I)* DX >*/
data_1.y[i - 1] = yi - data_1.bet[i - 1] * dx;
/*< Z( I)= ZI- SALP( I)* DX >*/
data_1.z[i - 1] = zi - angl_1.salp[i - 1] * dx;
/*< SI( I)= XI+ ALP( I)* DX >*/
data_1.si[i - 1] = xi + data_1.alp[i - 1] * dx;
/*< ALP( I)= YI+ BET( I)* DX >*/
data_1.alp[i - 1] = yi + data_1.bet[i - 1] * dx;
/*< BET( I)= ZI+ SALP( I)* DX >*/
data_1.bet[i - 1] = zi + angl_1.salp[i - 1] * dx;
/*< BI( I)= BI( I)* WLAM >*/
data_1.bi[i - 1] *= data_1.wlam;
/*< 1 CONTINUE >*/
/* L1: */
}
/*< 2 IF( M1.EQ.0) GOTO 4 >*/
L2:
if (data_1.m1 == 0) {
goto L4;
}
/* READ PATCH DATA AND CONVERT TO METERS */
/*< J= LD- M1+1 >*/
j = data_1.ld - data_1.m1 + 1;
/*< >*/
io___913.ciunit = igfl;
s_rsue(&io___913);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.ld;
for (i = j; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< >*/
io___914.ciunit = igfl;
s_rsue(&io___914);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.ld;
for (i = j; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< READ( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD) >*/
io___915.ciunit = igfl;
s_rsue(&io___915);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
;
}
e_rsue();
/*< READ( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD) >*/
io___916.ciunit = igfl;
s_rsue(&io___916);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
}
e_rsue();
/*< READ( IGFL) ( ITAG( I), I= J, LD) >*/
io___917.ciunit = igfl;
s_rsue(&io___917);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
}
e_rsue();
/*< DX= WLAM* WLAM >*/
dx = data_1.wlam * data_1.wlam;
/*< DO 3 I= J, LD >*/
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
/*< X( I)= X( I)* WLAM >*/
data_1.x[i - 1] *= data_1.wlam;
/*< Y( I)= Y( I)* WLAM >*/
data_1.y[i - 1] *= data_1.wlam;
/*< Z( I)= Z( I)* WLAM >*/
data_1.z[i - 1] *= data_1.wlam;
/*< 3 BI( I)= BI( I)* DX >*/
/* L3: */
data_1.bi[i - 1] *= dx;
}
/*< >*/
L4:
io___918.ciunit = igfl;
s_rsue(&io___918);
do_uio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
e_rsue();
/*< >*/
if (gnd_1.iperf == 2) {
io___919.ciunit = igfl;
s_rsue(&io___919);
do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
e_rsue();
}
/*< NEQ= N1+2* M1 >*/
neq = data_1.n1 + (data_1.m1 << 1);
/*< NPEQ= NP+2* MP >*/
npeq = data_1.np + (data_1.mp << 1);
/*< NOP= NEQ/ NPEQ >*/
nop = neq / npeq;
/*< IF( NOP.GT.1) READ( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP) >*/
if (nop > 1) {
io___923.ciunit = igfl;
s_rsue(&io___923);
i__1 = nop;
for (j = 1; j <= i__1; ++j) {
i__2 = nop;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&smat_1.ssx[i + (j << 4) - 17], (ftnlen)
sizeof(doublereal));
}
}
e_rsue();
}
/* READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE */
/*< READ( IGFL) ( IP( I), I=1, NEQ), COM >*/
io___924.ciunit = igfl;
s_rsue(&io___924);
i__2 = neq;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&save_1.ip[i - 1], (ftnlen)sizeof(integer));
}
do_uio(&c__95, (char *)&save_1.com[0], (ftnlen)sizeof(doublereal));
e_rsue();
/*< IF( ICASE.GT.2) GOTO 5 >*/
if (matpar_1.icase > 2) {
goto L5;
}
/*< IOUT= NEQ* NPEQ >*/
iout = neq * npeq;
/*< READ( IGFL) ( CM( I), I=1, IOUT) >*/
io___926.ciunit = igfl;
s_rsue(&io___926);
i__2 = iout;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&cmb_1.cm[i - 1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< GOTO 10 >*/
goto L10;
/*< 5 REWIND 13 >*/
L5:
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/*< IF( ICASE.NE.4) GOTO 7 >*/
if (matpar_1.icase != 4) {
goto L7;
}
/*< IOUT= NPEQ* NPEQ >*/
iout = npeq * npeq;
/*< DO 6 K=1, NOP >*/
i__2 = nop;
for (k = 1; k <= i__2; ++k) {
/*< READ( IGFL) ( CM( J), J=1, IOUT) >*/
io___928.ciunit = igfl;
s_rsue(&io___928);
i__1 = iout;
for (j = 1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
);
}
e_rsue();
/*< 6 WRITE( 13) ( CM( J), J=1, IOUT) >*/
/* L6: */
s_wsue(&io___929);
i__1 = iout;
for (j = 1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
);
}
e_wsue();
}
/*< GOTO 9 >*/
goto L9;
/*< 7 IOUT= NPSYM* NPEQ*2 >*/
L7:
iout = matpar_1.npsym * npeq << 1;
/*< NBL2=2* NBLSYM >*/
nbl2 = matpar_1.nblsym << 1;
/*< DO 8 IOP=1, NOP >*/
i__1 = nop;
for (iop = 1; iop <= i__1; ++iop) {
/*< DO 8 I=1, NBL2 >*/
i__2 = nbl2;
for (i = 1; i <= i__2; ++i) {
/*< CALL BLCKIN( CM, IGFL,1, IOUT,1,206) >*/
blckin_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__206);
/*< 8 CALL BLCKOT( CM,13,1, IOUT,1,205) >*/
/* L8: */
blckot_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__205);
}
}
/*< 9 REWIND 13 >*/
L9:
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/* WRITE(6,N) G.F. HEADING */
/*< 10 REWIND IGFL >*/
L10:
al__1.aerr = 0;
al__1.aunit = igfl;
f_rew(&al__1);
/*< WRITE( 6,16) >*/
s_wsfe(&io___932);
e_wsfe();
/*< WRITE( 6,14) >*/
s_wsfe(&io___933);
e_wsfe();
/*< WRITE( 6,14) >*/
s_wsfe(&io___934);
e_wsfe();
/*< WRITE( 6,17) >*/
s_wsfe(&io___935);
e_wsfe();
/*< WRITE( 6,18) N1, M1 >*/
s_wsfe(&io___936);
do_fio(&c__1, (char *)&data_1.n1, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.m1, (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( NOP.GT.1) WRITE( 6,19) NOP >*/
if (nop > 1) {
s_wsfe(&io___937);
do_fio(&c__1, (char *)&nop, (ftnlen)sizeof(integer));
e_wsfe();
}
/*< WRITE( 6,20) IMAT, ICASE >*/
s_wsfe(&io___938);
do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
e_wsfe();
/*< IF( ICASE.LT.3) GOTO 11 >*/
if (matpar_1.icase < 3) {
goto L11;
}
/*< NBL2= NEQ* NPEQ >*/
nbl2 = neq * npeq;
/*< WRITE( 6,21) NBL2 >*/
s_wsfe(&io___939);
do_fio(&c__1, (char *)&nbl2, (ftnlen)sizeof(integer));
e_wsfe();
/*< 11 WRITE( 6,22) FMHZ >*/
L11:
s_wsfe(&io___940);
do_fio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( KSYMP.EQ.2.AND. IPERF.EQ.1) WRITE( 6,23) >*/
if (gnd_1.ksymp == 2 && gnd_1.iperf == 1) {
s_wsfe(&io___941);
e_wsfe();
}
/*< IF( KSYMP.EQ.2.AND. IPERF.EQ.0) WRITE( 6,27) >*/
if (gnd_1.ksymp == 2 && gnd_1.iperf == 0) {
s_wsfe(&io___942);
e_wsfe();
}
/*< IF( KSYMP.EQ.2.AND. IPERF.EQ.2) WRITE( 6,28) >*/
if (gnd_1.ksymp == 2 && gnd_1.iperf == 2) {
s_wsfe(&io___943);
e_wsfe();
}
/*< IF( KSYMP.EQ.2.AND. IPERF.NE.1) WRITE( 6,24) EPSR, SIG >*/
if (gnd_1.ksymp == 2 && gnd_1.iperf != 1) {
s_wsfe(&io___944);
do_fio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/*< WRITE( 6,17) >*/
s_wsfe(&io___945);
e_wsfe();
/*< DO 12 J=1, KCOM >*/
i__2 = save_1.kcom;
for (j = 1; j <= i__2; ++j) {
/*< 12 WRITE( 6,15) ( COM( I, J), I=1,19) >*/
/* L12: */
s_wsfe(&io___946);
for (i = 1; i <= 19; ++i) {
do_fio(&c__1, (char *)&save_1.com[i + j * 19 - 20], (ftnlen)
sizeof(doublereal));
}
e_wsfe();
}
/*< WRITE( 6,17) >*/
s_wsfe(&io___947);
e_wsfe();
/*< WRITE( 6,14) >*/
s_wsfe(&io___948);
e_wsfe();
/*< WRITE( 6,14) >*/
s_wsfe(&io___949);
e_wsfe();
/*< WRITE( 6,16) >*/
s_wsfe(&io___950);
e_wsfe();
/*< IF( IPRT.EQ.0) RETURN >*/
if (*iprt == 0) {
return 0;
}
/*< WRITE( 6,25) >*/
s_wsfe(&io___951);
e_wsfe();
/*< DO 13 I=1, N1 >*/
i__2 = data_1.n1;
for (i = 1; i <= i__2; ++i) {
/*< 13 WRITE( 6,26) I, X( I), Y( I), Z( I), SI( I), ALP( I), BET( I) >*/
/* L13: */
s_wsfe(&io___952);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
e_wsfe();
}
/*< RETURN >*/
return 0;
/*< >*/
/*< 15 FORMAT(5X,3H** ,19A4,3H **) >*/
/*< 16 FORMAT(////) >*/
/*< 17 FORMAT(5X,2H**,80X,2H**) >*/
/*< >*/
/*< 19 FORMAT(5X,'** NO. SYMMETRIC SECTIONS =',I4,51X,2H**) >*/
/*< >*/
/*< 21 FORMAT(5X,2H**,19X,'MATRIX SIZE =',I7,' COMPLEX NUMBERS',25X,'**') >*/
/*< 22 FORMAT(5X,'** FREQUENCY =',1P,E12.5,' MHZ.',51X,2H**) >*/
/*< 23 FORMAT(5X,'** PERFECT GROUND',65X,2H**) >*/
/*< >*/
/*< >*/
/*< 26 FORMAT(1X,I7,1P,6E15.6) >*/
/*< >*/
/*< 28 FORMAT(5X,'** FINITE GROUND. SOMMERFELD SOLUTION',44X,'**') >*/
/*< END >*/
} /* gfil_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GFLD( RHO, PHI, RZ, ETH, EPI, ERD, UX, KSYMP) >*/
/* Subroutine */ int gfld_(rho, phi, rz, eth, epi, erd, ux, ksymp)
doublereal *rho, *phi, *rz;
doublecomplex *eth, *epi, *erd, *ux;
integer *ksymp;
{
/* Initialized data */
static doublereal pi = 3.141592654;
static doublereal tp = 6.283185308;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double sqrt(), z_abs(), atan(), cos(), sin();
/* Local variables */
extern /* Subroutine */ int ffld_();
static doublereal cbet, calp, sbet, sill, thet, rxyz, a, b, c;
static integer i, k;
static doublereal r, omega;
extern /* Subroutine */ int gwave_();
static doublereal el;
static doublecomplex ex, ey;
static doublereal dx, dy, dz, rr, ri, rx, ry;
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublereal arg;
static doublecomplex eph, exa, erh, cix, ciy, ciz, ezh, erv;
static doublereal phx, phy, rix;
static doublecomplex ezv;
static doublereal riy, rhs, rhp, rhx, rhy, cph, sph, rfl, riz, rnx, rny,
rnz, top, bot, too, boo, thx, thy, thz;
/* *** */
/* GFLD COMPUTES THE RADIATED FIELD INCLUDING GROUND WAVE. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMPLEX EZH, EX, EY, ETH, UX, ERD >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
/*< DIMENSION CAB(1), SAB(1) >*/
/*< EQUIVALENCE(CAB(1),ALP(1)),(SAB(1),BET(1)) >*/
/*< DATA PI, TP/3.141592654D+0,6.283185308D+0/ >*/
/*< R= SQRT( RHO* RHO+ RZ* RZ) >*/
r = sqrt(*rho * *rho + *rz * *rz);
/*< IF( KSYMP.EQ.1) GOTO 1 >*/
if (*ksymp == 1) {
goto L1;
}
/*< IF( ABS( UX).GT..5) GOTO 1 >*/
if (z_abs(ux) > .5) {
goto L1;
}
/*< IF( R.GT.1.E5) GOTO 1 >*/
if (r > 1e5) {
goto L1;
}
/* COMPUTATION OF SPACE WAVE ONLY */
/*< GOTO 4 >*/
goto L4;
/*< 1 IF( RZ.LT.1.D-20) GOTO 2 >*/
L1:
if (*rz < 1e-20) {
goto L2;
}
/*< THET= ATAN( RHO/ RZ) >*/
thet = atan(*rho / *rz);
/*< GOTO 3 >*/
goto L3;
/*< 2 THET= PI*.5 >*/
L2:
thet = pi * .5;
/*< 3 CALL FFLD( THET, PHI, ETH, EPI) >*/
L3:
ffld_(&thet, phi, eth, epi);
/*< ARG=- TP* R >*/
arg = -tp * r;
/*< EXA= CMPLX( COS( ARG), SIN( ARG))/ R >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__2.r = d__1, z__2.i = d__2;
z__1.r = z__2.r / r, z__1.i = z__2.i / r;
exa.r = z__1.r, exa.i = z__1.i;
/*< ETH= ETH* EXA >*/
z__1.r = eth->r * exa.r - eth->i * exa.i, z__1.i = eth->r * exa.i +
eth->i * exa.r;
eth->r = z__1.r, eth->i = z__1.i;
/*< EPI= EPI* EXA >*/
z__1.r = epi->r * exa.r - epi->i * exa.i, z__1.i = epi->r * exa.i +
epi->i * exa.r;
epi->r = z__1.r, epi->i = z__1.i;
/*< ERD=(0.,0.) >*/
erd->r = 0., erd->i = 0.;
/* COMPUTATION OF SPACE AND GROUND WAVES. */
/*< RETURN >*/
return 0;
/*< 4 U= UX >*/
L4:
gwav_1.u.r = ux->r, gwav_1.u.i = ux->i;
/*< U2= U* U >*/
z__1.r = gwav_1.u.r * gwav_1.u.r - gwav_1.u.i * gwav_1.u.i, z__1.i =
gwav_1.u.r * gwav_1.u.i + gwav_1.u.i * gwav_1.u.r;
gwav_1.u2.r = z__1.r, gwav_1.u2.i = z__1.i;
/*< PHX=- SIN( PHI) >*/
phx = -sin(*phi);
/*< PHY= COS( PHI) >*/
phy = cos(*phi);
/*< RX= RHO* PHY >*/
rx = *rho * phy;
/*< RY=- RHO* PHX >*/
ry = -(*rho) * phx;
/*< CIX=(0.,0.) >*/
cix.r = 0., cix.i = 0.;
/*< CIY=(0.,0.) >*/
ciy.r = 0., ciy.i = 0.;
/* SUMMATION OF FIELD FROM INDIVIDUAL SEGMENTS */
/*< CIZ=(0.,0.) >*/
ciz.r = 0., ciz.i = 0.;
/*< DO 17 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< DX= CAB( I) >*/
dx = cab[i - 1];
/*< DY= SAB( I) >*/
dy = sab[i - 1];
/*< DZ= SALP( I) >*/
dz = angl_1.salp[i - 1];
/*< RIX= RX- X( I) >*/
rix = rx - data_1.x[i - 1];
/*< RIY= RY- Y( I) >*/
riy = ry - data_1.y[i - 1];
/*< RHS= RIX* RIX+ RIY* RIY >*/
rhs = rix * rix + riy * riy;
/*< RHP= SQRT( RHS) >*/
rhp = sqrt(rhs);
/*< IF( RHP.LT.1.D-6) GOTO 5 >*/
if (rhp < 1e-6) {
goto L5;
}
/*< RHX= RIX/ RHP >*/
rhx = rix / rhp;
/*< RHY= RIY/ RHP >*/
rhy = riy / rhp;
/*< GOTO 6 >*/
goto L6;
/*< 5 RHX=1. >*/
L5:
rhx = 1.;
/*< RHY=0. >*/
rhy = 0.;
/*< 6 CALP=1.- DZ* DZ >*/
L6:
calp = 1. - dz * dz;
/*< IF( CALP.LT.1.D-6) GOTO 7 >*/
if (calp < 1e-6) {
goto L7;
}
/*< CALP= SQRT( CALP) >*/
calp = sqrt(calp);
/*< CBET= DX/ CALP >*/
cbet = dx / calp;
/*< SBET= DY/ CALP >*/
sbet = dy / calp;
/*< CPH= RHX* CBET+ RHY* SBET >*/
cph = rhx * cbet + rhy * sbet;
/*< SPH= RHY* CBET- RHX* SBET >*/
sph = rhy * cbet - rhx * sbet;
/*< GOTO 8 >*/
goto L8;
/*< 7 CPH= RHX >*/
L7:
cph = rhx;
/*< SPH= RHY >*/
sph = rhy;
/*< 8 EL= PI* SI( I) >*/
L8:
el = pi * data_1.si[i - 1];
/* INTEGRATION OF (CURRENT)*(PHASE FACTOR) OVER SEGMENT AND IMAGE
FOR */
/* CONSTANT, SINE, AND COSINE CURRENT DISTRIBUTIONS */
/*< RFL=-1. >*/
rfl = -1.;
/*< DO 16 K=1,2 >*/
for (k = 1; k <= 2; ++k) {
/*< RFL=- RFL >*/
rfl = -rfl;
/*< RIZ= RZ- Z( I)* RFL >*/
riz = *rz - data_1.z[i - 1] * rfl;
/*< RXYZ= SQRT( RIX* RIX+ RIY* RIY+ RIZ* RIZ) >*/
d__1 = rix * rix + riy * riy;
rxyz = sqrt(d__1 + riz * riz);
/*< RNX= RIX/ RXYZ >*/
rnx = rix / rxyz;
/*< RNY= RIY/ RXYZ >*/
rny = riy / rxyz;
/*< RNZ= RIZ/ RXYZ >*/
rnz = riz / rxyz;
/*< OMEGA=-( RNX* DX+ RNY* DY+ RNZ* DZ* RFL) >*/
d__1 = rnx * dx + rny * dy;
d__2 = rnz * dz;
omega = -(d__1 + d__2 * rfl);
/*< SILL= OMEGA* EL >*/
sill = omega * el;
/*< TOP= EL+ SILL >*/
top = el + sill;
/*< BOT= EL- SILL >*/
bot = el - sill;
/*< IF( ABS( OMEGA).LT.1.D-7) GOTO 9 >*/
if (abs(omega) < 1e-7) {
goto L9;
}
/*< A=2.* SIN( SILL)/ OMEGA >*/
a = sin(sill) * 2. / omega;
/*< GOTO 10 >*/
goto L10;
/*< 9 A=(2.- OMEGA* OMEGA* EL* EL/3.)* EL >*/
L9:
d__2 = omega * omega;
d__1 = d__2 * el;
a = (2. - d__1 * el / 3.) * el;
/*< 10 IF( ABS( TOP).LT.1.D-7) GOTO 11 >*/
L10:
if (abs(top) < 1e-7) {
goto L11;
}
/*< TOO= SIN( TOP)/ TOP >*/
too = sin(top) / top;
/*< GOTO 12 >*/
goto L12;
/*< 11 TOO=1.- TOP* TOP/6. >*/
L11:
too = 1. - top * top / 6.;
/*< 12 IF( ABS( BOT).LT.1.D-7) GOTO 13 >*/
L12:
if (abs(bot) < 1e-7) {
goto L13;
}
/*< BOO= SIN( BOT)/ BOT >*/
boo = sin(bot) / bot;
/*< GOTO 14 >*/
goto L14;
/*< 13 BOO=1.- BOT* BOT/6. >*/
L13:
boo = 1. - bot * bot / 6.;
/*< 14 B= EL*( BOO- TOO) >*/
L14:
b = el * (boo - too);
/*< C= EL*( BOO+ TOO) >*/
c = el * (boo + too);
/*< RR= A* AIR( I)+ B* BII( I)+ C* CIR( I) >*/
d__1 = a * crnt_1.air[i - 1] + b * crnt_1.bii[i - 1];
rr = d__1 + c * crnt_1.cir[i - 1];
/*< RI= A* AII( I)- B* BIR( I)+ C* CII( I) >*/
ri = a * crnt_1.aii[i - 1] - b * crnt_1.bir[i - 1] + c *
crnt_1.cii[i - 1];
/*< ARG= TP*( X( I)* RNX+ Y( I)* RNY+ Z( I)* RNZ* RFL) >*/
d__1 = data_1.x[i - 1] * rnx + data_1.y[i - 1] * rny;
d__2 = data_1.z[i - 1] * rnz;
arg = tp * (d__1 + d__2 * rfl);
/*< EXA= CMPLX( COS( ARG), SIN( ARG))* CMPLX( RR, RI)/ TP >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__3.r = d__1, z__3.i = d__2;
z__4.r = rr, z__4.i = ri;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r *
z__4.i + z__3.i * z__4.r;
z__1.r = z__2.r / tp, z__1.i = z__2.i / tp;
exa.r = z__1.r, exa.i = z__1.i;
/*< IF( K.EQ.2) GOTO 15 >*/
if (k == 2) {
goto L15;
}
/*< XX1= EXA >*/
gwav_1.xx1.r = exa.r, gwav_1.xx1.i = exa.i;
/*< R1= RXYZ >*/
gwav_1.r1 = rxyz;
/*< ZMH= RIZ >*/
gwav_1.zmh = riz;
/*< GOTO 16 >*/
goto L16;
/*< 15 XX2= EXA >*/
L15:
gwav_1.xx2.r = exa.r, gwav_1.xx2.i = exa.i;
/*< R2= RXYZ >*/
gwav_1.r2 = rxyz;
/*< ZPH= RIZ >*/
gwav_1.zph = riz;
/* CALL SUBROUTINE TO COMPUTE THE FIELD OF SEGMENT INCLUDING G
ROUND */
/* WAVE. */
/*< 16 CONTINUE >*/
L16:
;
}
/*< CALL GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
gwave_(&erv, &ezv, &erh, &ezh, &eph);
/*< ERH= ERH* CPH* CALP+ ERV* DZ >*/
z__3.r = cph * erh.r, z__3.i = cph * erh.i;
z__2.r = calp * z__3.r, z__2.i = calp * z__3.i;
z__4.r = dz * erv.r, z__4.i = dz * erv.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
erh.r = z__1.r, erh.i = z__1.i;
/*< EPH= EPH* SPH* CALP >*/
z__2.r = sph * eph.r, z__2.i = sph * eph.i;
z__1.r = calp * z__2.r, z__1.i = calp * z__2.i;
eph.r = z__1.r, eph.i = z__1.i;
/*< EZH= EZH* CPH* CALP+ EZV* DZ >*/
z__3.r = cph * ezh.r, z__3.i = cph * ezh.i;
z__2.r = calp * z__3.r, z__2.i = calp * z__3.i;
z__4.r = dz * ezv.r, z__4.i = dz * ezv.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ezh.r = z__1.r, ezh.i = z__1.i;
/*< EX= ERH* RHX- EPH* RHY >*/
z__2.r = rhx * erh.r, z__2.i = rhx * erh.i;
z__3.r = rhy * eph.r, z__3.i = rhy * eph.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
ex.r = z__1.r, ex.i = z__1.i;
/*< EY= ERH* RHY+ EPH* RHX >*/
z__2.r = rhy * erh.r, z__2.i = rhy * erh.i;
z__3.r = rhx * eph.r, z__3.i = rhx * eph.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
ey.r = z__1.r, ey.i = z__1.i;
/*< CIX= CIX+ EX >*/
z__1.r = cix.r + ex.r, z__1.i = cix.i + ex.i;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CIY+ EY >*/
z__1.r = ciy.r + ey.r, z__1.i = ciy.i + ey.i;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< 17 CIZ= CIZ+ EZH >*/
/* L17: */
z__1.r = ciz.r + ezh.r, z__1.i = ciz.i + ezh.i;
ciz.r = z__1.r, ciz.i = z__1.i;
}
/*< ARG=- TP* R >*/
arg = -tp * r;
/*< EXA= CMPLX( COS( ARG), SIN( ARG)) >*/
d__1 = cos(arg);
d__2 = sin(arg);
z__1.r = d__1, z__1.i = d__2;
exa.r = z__1.r, exa.i = z__1.i;
/*< CIX= CIX* EXA >*/
z__1.r = cix.r * exa.r - cix.i * exa.i, z__1.i = cix.r * exa.i + cix.i *
exa.r;
cix.r = z__1.r, cix.i = z__1.i;
/*< CIY= CIY* EXA >*/
z__1.r = ciy.r * exa.r - ciy.i * exa.i, z__1.i = ciy.r * exa.i + ciy.i *
exa.r;
ciy.r = z__1.r, ciy.i = z__1.i;
/*< CIZ= CIZ* EXA >*/
z__1.r = ciz.r * exa.r - ciz.i * exa.i, z__1.i = ciz.r * exa.i + ciz.i *
exa.r;
ciz.r = z__1.r, ciz.i = z__1.i;
/*< RNX= RX/ R >*/
rnx = rx / r;
/*< RNY= RY/ R >*/
rny = ry / r;
/*< RNZ= RZ/ R >*/
rnz = *rz / r;
/*< THX= RNZ* PHY >*/
thx = rnz * phy;
/*< THY=- RNZ* PHX >*/
thy = -rnz * phx;
/*< THZ=- RHO/ R >*/
thz = -(*rho) / r;
/*< ETH= CIX* THX+ CIY* THY+ CIZ* THZ >*/
z__3.r = thx * cix.r, z__3.i = thx * cix.i;
z__4.r = thy * ciy.r, z__4.i = thy * ciy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = thz * ciz.r, z__5.i = thz * ciz.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
eth->r = z__1.r, eth->i = z__1.i;
/*< EPI= CIX* PHX+ CIY* PHY >*/
z__2.r = phx * cix.r, z__2.i = phx * cix.i;
z__3.r = phy * ciy.r, z__3.i = phy * ciy.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
epi->r = z__1.r, epi->i = z__1.i;
/*< ERD= CIX* RNX+ CIY* RNY+ CIZ* RNZ >*/
z__3.r = rnx * cix.r, z__3.i = rnx * cix.i;
z__4.r = rny * ciy.r, z__4.i = rny * ciy.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rnz * ciz.r, z__5.i = rnz * ciz.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
erd->r = z__1.r, erd->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gfld_ */
#undef sab
#undef cab
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GFOUT >*/
/* Subroutine */ int gfout_()
{
/* Initialized data */
static integer igfl = 20;
/* Format strings */
static char fmt_13[] = "(///,\002 ****NUMERICAL GREEN S FUNCTION FILE ON\
TAPE\002,i3,\002****\002,/,5x,\002MATRIX STORAGE -\002,i7,\002 COMPLEX NUMB\
ERS\002,///)";
/* System generated locals */
integer i__1, i__2, i__3;
alist al__1;
/* Builtin functions */
integer s_wsue(), do_uio(), e_wsue(), f_rew(), s_rsue(), e_rsue(), s_wsfe(
), do_fio(), e_wsfe();
/* Local variables */
static integer npeq, iout, i, j, k;
extern /* Subroutine */ int blckin_(), blckot_();
static integer neq, iop, nop;
/* Fortran I/O blocks */
static cilist io___1016 = { 0, 0, 0, 0, 0 };
static cilist io___1017 = { 0, 0, 0, 0, 0 };
static cilist io___1019 = { 0, 0, 0, 0, 0 };
static cilist io___1020 = { 0, 0, 0, 0, 0 };
static cilist io___1021 = { 0, 0, 0, 0, 0 };
static cilist io___1022 = { 0, 0, 0, 0, 0 };
static cilist io___1023 = { 0, 0, 0, 0, 0 };
static cilist io___1025 = { 0, 0, 0, 0, 0 };
static cilist io___1026 = { 0, 0, 0, 0, 0 };
static cilist io___1027 = { 0, 0, 0, 0, 0 };
static cilist io___1028 = { 0, 0, 0, 0, 0 };
static cilist io___1029 = { 0, 0, 0, 0, 0 };
static cilist io___1030 = { 0, 0, 0, 0, 0 };
static cilist io___1031 = { 0, 0, 0, 0, 0 };
static cilist io___1032 = { 0, 0, 0, 0, 0 };
static cilist io___1033 = { 0, 0, 0, 0, 0 };
static cilist io___1035 = { 0, 0, 0, 0, 0 };
static cilist io___1037 = { 0, 13, 0, 0, 0 };
static cilist io___1038 = { 0, 0, 0, 0, 0 };
static cilist io___1040 = { 0, 6, 0, fmt_13, 0 };
/* *** */
/* WRITE N.G.F. FILE */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /CMB/ CM(90000) >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /SMAT/ SSX(16,16) >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< COMMON /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
/*< DATA IGFL/20/ >*/
/*< NEQ= N+2* M >*/
neq = data_1.n + (data_1.m << 1);
/*< NPEQ= NP+2* MP >*/
npeq = data_1.np + (data_1.mp << 1);
/*< NOP= NEQ/ NPEQ >*/
nop = neq / npeq;
/*< >*/
io___1016.ciunit = igfl;
s_wsue(&io___1016);
do_uio(&c__1, (char *)&data_1.n, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.np, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.m, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.mp, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&data_1.wlam, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.fmhz, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&data_1.ipsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.ksymp, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.iperf, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&save_1.epsr, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.sig, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
do_uio(&c__1, (char *)&zload_1.nload, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&save_1.kcom, (ftnlen)sizeof(integer));
e_wsue();
/*< IF( N.EQ.0) GOTO 1 >*/
if (data_1.n == 0) {
goto L1;
}
/*< WRITE( IGFL) ( X( I), I=1, N),( Y( I), I=1, N),( Z( I), I=1, N) >*/
io___1017.ciunit = igfl;
s_wsue(&io___1017);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.n;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< >*/
io___1019.ciunit = igfl;
s_wsue(&io___1019);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.n;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< WRITE( IGFL) ( BET( I), I=1, N),( SALP( I), I=1, N) >*/
io___1020.ciunit = igfl;
s_wsue(&io___1020);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
;
}
e_wsue();
/*< WRITE( IGFL) ( ICON1( I), I=1, N),( ICON2( I), I=1, N) >*/
io___1021.ciunit = igfl;
s_wsue(&io___1021);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
}
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
}
e_wsue();
/*< WRITE( IGFL) ( ITAG( I), I=1, N) >*/
io___1022.ciunit = igfl;
s_wsue(&io___1022);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
}
e_wsue();
/*< IF( NLOAD.GT.0) WRITE( IGFL) ( ZARRAY( I), I=1, N) >*/
if (zload_1.nload > 0) {
io___1023.ciunit = igfl;
s_wsue(&io___1023);
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
do_uio(&c__2, (char *)&zload_1.zarray[i - 1], (ftnlen)sizeof(
doublereal));
}
e_wsue();
}
/*< 1 IF( M.EQ.0) GOTO 2 >*/
L1:
if (data_1.m == 0) {
goto L2;
}
/*< J= LD- M+1 >*/
j = data_1.ld - data_1.m + 1;
/*< >*/
io___1025.ciunit = igfl;
s_wsue(&io___1025);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.x[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.y[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.ld;
for (i = j; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.z[i - 1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< >*/
io___1026.ciunit = igfl;
s_wsue(&io___1026);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.si[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.bi[i - 1], (ftnlen)sizeof(doublereal));
}
i__3 = data_1.ld;
for (i = j; i <= i__3; ++i) {
do_uio(&c__1, (char *)&data_1.alp[i - 1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< WRITE( IGFL) ( BET( I), I= J, LD),( SALP( I), I= J, LD) >*/
io___1027.ciunit = igfl;
s_wsue(&io___1027);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.bet[i - 1], (ftnlen)sizeof(doublereal));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&angl_1.salp[i - 1], (ftnlen)sizeof(doublereal))
;
}
e_wsue();
/*< WRITE( IGFL) ( ICON1( I), I= J, LD),( ICON2( I), I= J, LD) >*/
io___1028.ciunit = igfl;
s_wsue(&io___1028);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.icon1[i - 1], (ftnlen)sizeof(integer));
}
i__2 = data_1.ld;
for (i = j; i <= i__2; ++i) {
do_uio(&c__1, (char *)&data_1.icon2[i - 1], (ftnlen)sizeof(integer));
}
e_wsue();
/*< WRITE( IGFL) ( ITAG( I), I= J, LD) >*/
io___1029.ciunit = igfl;
s_wsue(&io___1029);
i__1 = data_1.ld;
for (i = j; i <= i__1; ++i) {
do_uio(&c__1, (char *)&data_1.itag[i - 1], (ftnlen)sizeof(integer));
}
e_wsue();
/*< >*/
L2:
io___1030.ciunit = igfl;
s_wsue(&io___1030);
do_uio(&c__1, (char *)&matpar_1.icase, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nbloks, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.npblk, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nlast, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nblsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.npsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.nlsym, (ftnlen)sizeof(integer));
do_uio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
e_wsue();
/*< >*/
if (gnd_1.iperf == 2) {
io___1031.ciunit = igfl;
s_wsue(&io___1031);
do_uio(&c__880, (char *)&ggrid_1.ar1[0], (ftnlen)sizeof(doublereal));
do_uio(&c__680, (char *)&ggrid_1.ar2[0], (ftnlen)sizeof(doublereal));
do_uio(&c__576, (char *)&ggrid_1.ar3[0], (ftnlen)sizeof(doublereal));
do_uio(&c__2, (char *)&ggrid_1.epscf, (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dxa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.dya[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.xsa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.ysa[0], (ftnlen)sizeof(doublereal));
do_uio(&c__3, (char *)&ggrid_1.nxa[0], (ftnlen)sizeof(integer));
do_uio(&c__3, (char *)&ggrid_1.nya[0], (ftnlen)sizeof(integer));
e_wsue();
}
/*< IF( NOP.GT.1) WRITE( IGFL) (( SSX( I, J), I=1, NOP), J=1, NOP) >*/
if (nop > 1) {
io___1032.ciunit = igfl;
s_wsue(&io___1032);
i__1 = nop;
for (j = 1; j <= i__1; ++j) {
i__2 = nop;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&smat_1.ssx[i + (j << 4) - 17], (ftnlen)
sizeof(doublereal));
}
}
e_wsue();
}
/*< WRITE( IGFL) ( IP( I), I=1, NEQ), COM >*/
io___1033.ciunit = igfl;
s_wsue(&io___1033);
i__2 = neq;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__1, (char *)&save_1.ip[i - 1], (ftnlen)sizeof(integer));
}
do_uio(&c__95, (char *)&save_1.com[0], (ftnlen)sizeof(doublereal));
e_wsue();
/*< IF( ICASE.GT.2) GOTO 3 >*/
if (matpar_1.icase > 2) {
goto L3;
}
/*< IOUT= NEQ* NPEQ >*/
iout = neq * npeq;
/*< WRITE( IGFL) ( CM( I), I=1, IOUT) >*/
io___1035.ciunit = igfl;
s_wsue(&io___1035);
i__2 = iout;
for (i = 1; i <= i__2; ++i) {
do_uio(&c__2, (char *)&cmb_1.cm[i - 1], (ftnlen)sizeof(doublereal));
}
e_wsue();
/*< GOTO 12 >*/
goto L12;
/*< 3 IF( ICASE.NE.4) GOTO 5 >*/
L3:
if (matpar_1.icase != 4) {
goto L5;
}
/*< REWIND 13 >*/
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/*< I= NPEQ* NPEQ >*/
i = npeq * npeq;
/*< DO 4 K=1, NOP >*/
i__2 = nop;
for (k = 1; k <= i__2; ++k) {
/*< READ( 13) ( CM( J), J=1, I) >*/
s_rsue(&io___1037);
i__1 = i;
for (j = 1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
);
}
e_rsue();
/*< 4 WRITE( IGFL) ( CM( J), J=1, I) >*/
/* L4: */
io___1038.ciunit = igfl;
s_wsue(&io___1038);
i__1 = i;
for (j = 1; j <= i__1; ++j) {
do_uio(&c__2, (char *)&cmb_1.cm[j - 1], (ftnlen)sizeof(doublereal)
);
}
e_wsue();
}
/*< REWIND 13 >*/
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/*< GOTO 12 >*/
goto L12;
/*< 5 REWIND 13 >*/
L5:
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< IF( ICASE.EQ.5) GOTO 8 >*/
if (matpar_1.icase == 5) {
goto L8;
}
/*< IOUT= NPBLK* NEQ*2 >*/
iout = matpar_1.npblk * neq << 1;
/*< DO 6 I=1, NBLOKS >*/
i__1 = matpar_1.nbloks;
for (i = 1; i <= i__1; ++i) {
/*< CALL BLCKIN( CM,13,1, IOUT,1,201) >*/
blckin_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__201);
/*< 6 CALL BLCKOT( CM, IGFL,1, IOUT,1,202) >*/
/* L6: */
blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__202);
}
/*< DO 7 I=1, NBLOKS >*/
i__1 = matpar_1.nbloks;
for (i = 1; i <= i__1; ++i) {
/*< CALL BLCKIN( CM,14,1, IOUT,1,203) >*/
blckin_(cmb_1.cm, &c__14, &c__1, &iout, &c__1, &c__203);
/*< 7 CALL BLCKOT( CM, IGFL,1, IOUT,1,204) >*/
/* L7: */
blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__204);
}
/*< GOTO 12 >*/
goto L12;
/*< 8 IOUT= NPSYM* NPEQ*2 >*/
L8:
iout = matpar_1.npsym * npeq << 1;
/*< DO 11 IOP=1, NOP >*/
i__1 = nop;
for (iop = 1; iop <= i__1; ++iop) {
/*< DO 9 I=1, NBLSYM >*/
i__2 = matpar_1.nblsym;
for (i = 1; i <= i__2; ++i) {
/*< CALL BLCKIN( CM,13,1, IOUT,1,205) >*/
blckin_(cmb_1.cm, &c__13, &c__1, &iout, &c__1, &c__205);
/*< 9 CALL BLCKOT( CM, IGFL,1, IOUT,1,206) >*/
/* L9: */
blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__206);
}
/*< DO 10 I=1, NBLSYM >*/
i__2 = matpar_1.nblsym;
for (i = 1; i <= i__2; ++i) {
/*< CALL BLCKIN( CM,14,1, IOUT,1,207) >*/
blckin_(cmb_1.cm, &c__14, &c__1, &iout, &c__1, &c__207);
/*< 10 CALL BLCKOT( CM, IGFL,1, IOUT,1,208) >*/
/* L10: */
blckot_(cmb_1.cm, &igfl, &c__1, &iout, &c__1, &c__208);
}
/*< 11 CONTINUE >*/
/* L11: */
}
/*< REWIND 13 >*/
al__1.aerr = 0;
al__1.aunit = 13;
f_rew(&al__1);
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< 12 REWIND IGFL >*/
L12:
al__1.aerr = 0;
al__1.aunit = igfl;
f_rew(&al__1);
/*< WRITE( 6,13) IGFL, IMAT >*/
s_wsfe(&io___1040);
do_fio(&c__1, (char *)&igfl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&matpar_1.imat, (ftnlen)sizeof(integer));
e_wsfe();
/*< RETURN >*/
return 0;
/*< >*/
/*< END >*/
} /* gfout_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GH( ZK, HR, HI) >*/
/* Subroutine */ int gh_(zk, hr, hi)
doublereal *zk, *hr, *hi;
{
/* Builtin functions */
double sqrt(), cos(), sin();
/* Local variables */
static doublereal r, rs, rr2, rr3, ckr, skr;
/* *** */
/* INTEGRAND FOR H FIELD OF A WIRE */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMMON /TMH/ ZPK, RHKS >*/
/*< RS= ZK- ZPK >*/
rs = *zk - tmh_1.zpk;
/*< RS= RHKS+ RS* RS >*/
rs = tmh_1.rhks + rs * rs;
/*< R= SQRT( RS) >*/
r = sqrt(rs);
/*< CKR= COS( R) >*/
ckr = cos(r);
/*< SKR= SIN( R) >*/
skr = sin(r);
/*< RR2=1./ RS >*/
rr2 = 1. / rs;
/*< RR3= RR2/ R >*/
rr3 = rr2 / r;
/*< HR= SKR* RR2+ CKR* RR3 >*/
*hr = skr * rr2 + ckr * rr3;
/*< HI= CKR* RR2- SKR* RR3 >*/
*hi = ckr * rr2 - skr * rr3;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gh_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
/* Subroutine */ int gwave_(erv, ezv, erh, ezh, eph)
doublecomplex *erv, *ezv, *erh, *ezh, *eph;
{
/* Initialized data */
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 1., 0. };
static struct {
doublereal e_1[3];
} equiv_1 = { 0., 6.283185308, 0. };
static struct {
doublereal e_1[3];
} equiv_2 = { 0., -188.367, 0. };
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
z__11, z__12, z__13, z__14;
/* Builtin functions */
double sqrt();
void z_sqrt(), z_div();
/* Local variables */
extern /* Double Complex */ int fbar_();
#define econ ((doublecomplex *)&equiv_2)
static doublereal cppp, sppp;
#define tpjx ((doublereal *)&equiv_1)
static doublereal cppp2, sppp2;
static doublecomplex f, g, v, w;
#define econx ((doublereal *)&equiv_2)
static doublecomplex p1, q1, t1, t2, t3, t4, x1, x2, x3, x4, x5, x6, x7;
#define fj ((doublecomplex *)&equiv_0)
static doublecomplex rh, rv, rk1, rk2, xr1, xr2;
static doublereal cpp;
#define fjx ((doublereal *)&equiv_0)
#define tpj ((doublecomplex *)&equiv_1)
static doublecomplex omr;
static doublereal spp, cpp2, spp2;
/* *** */
/* GWAVE COMPUTES THE ELECTRIC FIELD, INCLUDING GROUND WAVE, OF A */
/* CURRENT ELEMENT OVER A GROUND PLANE USING FORMULAS OF K.A. NORTON
*/
/* (PROC. IRE, SEPT., 1937, PP.1203,1236.) */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
/*< DIMENSION FJX(2), TPJX(2), ECONX(2) >*/
/*< EQUIVALENCE(FJ,FJX),(TPJ,TPJX),(ECON,ECONX) >*/
/*< DATA PI/3.141592654D+0/, FJX/0.,1./, TPJX/0.,6.283185308D+0/ >*/
/*< DATA ECONX/0.,-188.367/ >*/
/*< SPPP= ZMH/ R1 >*/
sppp = gwav_1.zmh / gwav_1.r1;
/*< SPPP2= SPPP* SPPP >*/
sppp2 = sppp * sppp;
/*< CPPP2=1.- SPPP2 >*/
cppp2 = 1. - sppp2;
/*< IF( CPPP2.LT.1.D-20) CPPP2=1.D-20 >*/
if (cppp2 < 1e-20) {
cppp2 = 1e-20;
}
/*< CPPP= SQRT( CPPP2) >*/
cppp = sqrt(cppp2);
/*< SPP= ZPH/ R2 >*/
spp = gwav_1.zph / gwav_1.r2;
/*< SPP2= SPP* SPP >*/
spp2 = spp * spp;
/*< CPP2=1.- SPP2 >*/
cpp2 = 1. - spp2;
/*< IF( CPP2.LT.1.D-20) CPP2=1.D-20 >*/
if (cpp2 < 1e-20) {
cpp2 = 1e-20;
}
/*< CPP= SQRT( CPP2) >*/
cpp = sqrt(cpp2);
/*< RK1=- TPJ* R1 >*/
z__2.r = -tpj->r, z__2.i = -tpj->i;
z__1.r = gwav_1.r1 * z__2.r, z__1.i = gwav_1.r1 * z__2.i;
rk1.r = z__1.r, rk1.i = z__1.i;
/*< RK2=- TPJ* R2 >*/
z__2.r = -tpj->r, z__2.i = -tpj->i;
z__1.r = gwav_1.r2 * z__2.r, z__1.i = gwav_1.r2 * z__2.i;
rk2.r = z__1.r, rk2.i = z__1.i;
/*< T1=1.- U2* CPP2 >*/
z__2.r = cpp2 * gwav_1.u2.r, z__2.i = cpp2 * gwav_1.u2.i;
z__1.r = 1. - z__2.r, z__1.i = -z__2.i;
t1.r = z__1.r, t1.i = z__1.i;
/*< T2= SQRT( T1) >*/
z_sqrt(&z__1, &t1);
t2.r = z__1.r, t2.i = z__1.i;
/*< T3=(1.-1./ RK1)/ RK1 >*/
z_div(&z__3, &c_b48, &rk1);
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &rk1);
t3.r = z__1.r, t3.i = z__1.i;
/*< T4=(1.-1./ RK2)/ RK2 >*/
z_div(&z__3, &c_b48, &rk2);
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_div(&z__1, &z__2, &rk2);
t4.r = z__1.r, t4.i = z__1.i;
/*< P1= RK2* U2* T1/(2.* CPP2) >*/
z__3.r = rk2.r * gwav_1.u2.r - rk2.i * gwav_1.u2.i, z__3.i = rk2.r *
gwav_1.u2.i + rk2.i * gwav_1.u2.r;
z__2.r = z__3.r * t1.r - z__3.i * t1.i, z__2.i = z__3.r * t1.i + z__3.i *
t1.r;
d__1 = cpp2 * 2.;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
p1.r = z__1.r, p1.i = z__1.i;
/*< RV=( SPP- U* T2)/( SPP+ U* T2) >*/
z__3.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__3.i = gwav_1.u.r *
t2.i + gwav_1.u.i * t2.r;
z__2.r = spp - z__3.r, z__2.i = -z__3.i;
z__5.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__5.i = gwav_1.u.r *
t2.i + gwav_1.u.i * t2.r;
z__4.r = spp + z__5.r, z__4.i = z__5.i;
z_div(&z__1, &z__2, &z__4);
rv.r = z__1.r, rv.i = z__1.i;
/*< OMR=1.- RV >*/
z__1.r = 1. - rv.r, z__1.i = -rv.i;
omr.r = z__1.r, omr.i = z__1.i;
/*< W=1./ OMR >*/
z_div(&z__1, &c_b48, &omr);
w.r = z__1.r, w.i = z__1.i;
/*< W=(4.,0.)* P1* W* W >*/
z__3.r = p1.r * 4. - p1.i * 0., z__3.i = p1.r * 0. + p1.i * 4.;
z__2.r = z__3.r * w.r - z__3.i * w.i, z__2.i = z__3.r * w.i + z__3.i *
w.r;
z__1.r = z__2.r * w.r - z__2.i * w.i, z__1.i = z__2.r * w.i + z__2.i *
w.r;
w.r = z__1.r, w.i = z__1.i;
/*< F= FBAR( W) >*/
fbar_(&z__1, &w);
f.r = z__1.r, f.i = z__1.i;
/*< Q1= RK2* T1/(2.* U2* CPP2) >*/
z__2.r = rk2.r * t1.r - rk2.i * t1.i, z__2.i = rk2.r * t1.i + rk2.i *
t1.r;
z__4.r = gwav_1.u2.r * 2., z__4.i = gwav_1.u2.i * 2.;
z__3.r = cpp2 * z__4.r, z__3.i = cpp2 * z__4.i;
z_div(&z__1, &z__2, &z__3);
q1.r = z__1.r, q1.i = z__1.i;
/*< RH=( T2- U* SPP)/( T2+ U* SPP) >*/
z__3.r = spp * gwav_1.u.r, z__3.i = spp * gwav_1.u.i;
z__2.r = t2.r - z__3.r, z__2.i = t2.i - z__3.i;
z__5.r = spp * gwav_1.u.r, z__5.i = spp * gwav_1.u.i;
z__4.r = t2.r + z__5.r, z__4.i = t2.i + z__5.i;
z_div(&z__1, &z__2, &z__4);
rh.r = z__1.r, rh.i = z__1.i;
/*< V=1./(1.+ RH) >*/
z__2.r = rh.r + 1., z__2.i = rh.i;
z_div(&z__1, &c_b48, &z__2);
v.r = z__1.r, v.i = z__1.i;
/*< V=(4.,0.)* Q1* V* V >*/
z__3.r = q1.r * 4. - q1.i * 0., z__3.i = q1.r * 0. + q1.i * 4.;
z__2.r = z__3.r * v.r - z__3.i * v.i, z__2.i = z__3.r * v.i + z__3.i *
v.r;
z__1.r = z__2.r * v.r - z__2.i * v.i, z__1.i = z__2.r * v.i + z__2.i *
v.r;
v.r = z__1.r, v.i = z__1.i;
/*< G= FBAR( V) >*/
fbar_(&z__1, &v);
g.r = z__1.r, g.i = z__1.i;
/*< XR1= XX1/ R1 >*/
z__1.r = gwav_1.xx1.r / gwav_1.r1, z__1.i = gwav_1.xx1.i / gwav_1.r1;
xr1.r = z__1.r, xr1.i = z__1.i;
/*< XR2= XX2/ R2 >*/
z__1.r = gwav_1.xx2.r / gwav_1.r2, z__1.i = gwav_1.xx2.i / gwav_1.r2;
xr2.r = z__1.r, xr2.i = z__1.i;
/*< X1= CPPP2* XR1 >*/
z__1.r = cppp2 * xr1.r, z__1.i = cppp2 * xr1.i;
x1.r = z__1.r, x1.i = z__1.i;
/*< X2= RV* CPP2* XR2 >*/
z__2.r = cpp2 * rv.r, z__2.i = cpp2 * rv.i;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x2.r = z__1.r, x2.i = z__1.i;
/*< X3= OMR* CPP2* F* XR2 >*/
z__3.r = cpp2 * omr.r, z__3.i = cpp2 * omr.i;
z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i *
f.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x3.r = z__1.r, x3.i = z__1.i;
/*< X4= U* T2* SPP*2.* XR2/ RK2 >*/
z__5.r = gwav_1.u.r * t2.r - gwav_1.u.i * t2.i, z__5.i = gwav_1.u.r *
t2.i + gwav_1.u.i * t2.r;
z__4.r = spp * z__5.r, z__4.i = spp * z__5.i;
z__3.r = z__4.r * 2., z__3.i = z__4.i * 2.;
z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i +
z__3.i * xr2.r;
z_div(&z__1, &z__2, &rk2);
x4.r = z__1.r, x4.i = z__1.i;
/*< X5= XR1* T3*(1.-3.* SPPP2) >*/
z__2.r = xr1.r * t3.r - xr1.i * t3.i, z__2.i = xr1.r * t3.i + xr1.i *
t3.r;
d__1 = 1. - sppp2 * 3.;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
x5.r = z__1.r, x5.i = z__1.i;
/*< X6= XR2* T4*(1.-3.* SPP2) >*/
z__2.r = xr2.r * t4.r - xr2.i * t4.i, z__2.i = xr2.r * t4.i + xr2.i *
t4.r;
d__1 = 1. - spp2 * 3.;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
x6.r = z__1.r, x6.i = z__1.i;
/*< EZV=( X1+ X2+ X3- X4- X5- X6)* ECON >*/
z__6.r = x1.r + x2.r, z__6.i = x1.i + x2.i;
z__5.r = z__6.r + x3.r, z__5.i = z__6.i + x3.i;
z__4.r = z__5.r - x4.r, z__4.i = z__5.i - x4.i;
z__3.r = z__4.r - x5.r, z__3.i = z__4.i - x5.i;
z__2.r = z__3.r - x6.r, z__2.i = z__3.i - x6.i;
z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i +
z__2.i * econ->r;
ezv->r = z__1.r, ezv->i = z__1.i;
/*< X1= SPPP* CPPP* XR1 >*/
d__1 = sppp * cppp;
z__1.r = d__1 * xr1.r, z__1.i = d__1 * xr1.i;
x1.r = z__1.r, x1.i = z__1.i;
/*< X2= RV* SPP* CPP* XR2 >*/
z__3.r = spp * rv.r, z__3.i = spp * rv.i;
z__2.r = cpp * z__3.r, z__2.i = cpp * z__3.i;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x2.r = z__1.r, x2.i = z__1.i;
/*< X3= CPP* OMR* U* T2* F* XR2 >*/
z__5.r = cpp * omr.r, z__5.i = cpp * omr.i;
z__4.r = z__5.r * gwav_1.u.r - z__5.i * gwav_1.u.i, z__4.i = z__5.r *
gwav_1.u.i + z__5.i * gwav_1.u.r;
z__3.r = z__4.r * t2.r - z__4.i * t2.i, z__3.i = z__4.r * t2.i + z__4.i *
t2.r;
z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i *
f.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x3.r = z__1.r, x3.i = z__1.i;
/*< X4= SPP* CPP* OMR* XR2/ RK2 >*/
d__1 = spp * cpp;
z__3.r = d__1 * omr.r, z__3.i = d__1 * omr.i;
z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i +
z__3.i * xr2.r;
z_div(&z__1, &z__2, &rk2);
x4.r = z__1.r, x4.i = z__1.i;
/*< X5=3.* SPPP* CPPP* T3* XR1 >*/
d__2 = sppp * 3.;
d__1 = d__2 * cppp;
z__2.r = d__1 * t3.r, z__2.i = d__1 * t3.i;
z__1.r = z__2.r * xr1.r - z__2.i * xr1.i, z__1.i = z__2.r * xr1.i +
z__2.i * xr1.r;
x5.r = z__1.r, x5.i = z__1.i;
/*< X6= CPP* U* T2* OMR* XR2/ RK2*.5 >*/
z__6.r = cpp * gwav_1.u.r, z__6.i = cpp * gwav_1.u.i;
z__5.r = z__6.r * t2.r - z__6.i * t2.i, z__5.i = z__6.r * t2.i + z__6.i *
t2.r;
z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i +
z__5.i * omr.r;
z__3.r = z__4.r * xr2.r - z__4.i * xr2.i, z__3.i = z__4.r * xr2.i +
z__4.i * xr2.r;
z_div(&z__2, &z__3, &rk2);
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
x6.r = z__1.r, x6.i = z__1.i;
/*< X7=3.* SPP* CPP* T4* XR2 >*/
d__2 = spp * 3.;
d__1 = d__2 * cpp;
z__2.r = d__1 * t4.r, z__2.i = d__1 * t4.i;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x7.r = z__1.r, x7.i = z__1.i;
/*< ERV=-( X1+ X2- X3+ X4- X5+ X6- X7)* ECON >*/
z__8.r = x1.r + x2.r, z__8.i = x1.i + x2.i;
z__7.r = z__8.r - x3.r, z__7.i = z__8.i - x3.i;
z__6.r = z__7.r + x4.r, z__6.i = z__7.i + x4.i;
z__5.r = z__6.r - x5.r, z__5.i = z__6.i - x5.i;
z__4.r = z__5.r + x6.r, z__4.i = z__5.i + x6.i;
z__3.r = z__4.r - x7.r, z__3.i = z__4.i - x7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i +
z__2.i * econ->r;
erv->r = z__1.r, erv->i = z__1.i;
/*< EZH=-( X1- X2+ X3- X4- X5- X6+ X7)* ECON >*/
z__8.r = x1.r - x2.r, z__8.i = x1.i - x2.i;
z__7.r = z__8.r + x3.r, z__7.i = z__8.i + x3.i;
z__6.r = z__7.r - x4.r, z__6.i = z__7.i - x4.i;
z__5.r = z__6.r - x5.r, z__5.i = z__6.i - x5.i;
z__4.r = z__5.r - x6.r, z__4.i = z__5.i - x6.i;
z__3.r = z__4.r + x7.r, z__3.i = z__4.i + x7.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i +
z__2.i * econ->r;
ezh->r = z__1.r, ezh->i = z__1.i;
/*< X1= SPPP2* XR1 >*/
z__1.r = sppp2 * xr1.r, z__1.i = sppp2 * xr1.i;
x1.r = z__1.r, x1.i = z__1.i;
/*< X2= RV* SPP2* XR2 >*/
z__2.r = spp2 * rv.r, z__2.i = spp2 * rv.i;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x2.r = z__1.r, x2.i = z__1.i;
/*< X4= U2* T1* OMR* F* XR2 >*/
z__4.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__4.i = gwav_1.u2.r *
t1.i + gwav_1.u2.i * t1.r;
z__3.r = z__4.r * omr.r - z__4.i * omr.i, z__3.i = z__4.r * omr.i +
z__4.i * omr.r;
z__2.r = z__3.r * f.r - z__3.i * f.i, z__2.i = z__3.r * f.i + z__3.i *
f.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x4.r = z__1.r, x4.i = z__1.i;
/*< X5= T3*(1.-3.* CPPP2)* XR1 >*/
d__1 = 1. - cppp2 * 3.;
z__2.r = d__1 * t3.r, z__2.i = d__1 * t3.i;
z__1.r = z__2.r * xr1.r - z__2.i * xr1.i, z__1.i = z__2.r * xr1.i +
z__2.i * xr1.r;
x5.r = z__1.r, x5.i = z__1.i;
/*< X6= T4*(1.-3.* CPP2)*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2 >*/
d__1 = 1. - cpp2 * 3.;
z__3.r = d__1 * t4.r, z__3.i = d__1 * t4.i;
z__7.r = rv.r + 1., z__7.i = rv.i;
z__6.r = gwav_1.u2.r * z__7.r - gwav_1.u2.i * z__7.i, z__6.i =
gwav_1.u2.r * z__7.i + gwav_1.u2.i * z__7.r;
z__5.r = 1. - z__6.r, z__5.i = -z__6.i;
z__9.r = gwav_1.u2.r * omr.r - gwav_1.u2.i * omr.i, z__9.i = gwav_1.u2.r *
omr.i + gwav_1.u2.i * omr.r;
z__8.r = z__9.r * f.r - z__9.i * f.i, z__8.i = z__9.r * f.i + z__9.i *
f.r;
z__4.r = z__5.r - z__8.r, z__4.i = z__5.i - z__8.i;
z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i +
z__3.i * z__4.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x6.r = z__1.r, x6.i = z__1.i;
/*< >*/
z__5.r = cpp2 * gwav_1.u2.r, z__5.i = cpp2 * gwav_1.u2.i;
z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i +
z__5.i * omr.r;
z_div(&z__7, &c_b48, &rk2);
z__6.r = 1. - z__7.r, z__6.i = -z__7.i;
z__3.r = z__4.r * z__6.r - z__4.i * z__6.i, z__3.i = z__4.r * z__6.i +
z__4.i * z__6.r;
z__12.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__12.i = gwav_1.u2.r *
t1.i + gwav_1.u2.i * t1.r;
z__11.r = z__12.r - spp2, z__11.i = z__12.i;
z_div(&z__13, &c_b48, &rk2);
z__10.r = z__11.r - z__13.r, z__10.i = z__11.i - z__13.i;
z__9.r = f.r * z__10.r - f.i * z__10.i, z__9.i = f.r * z__10.i + f.i *
z__10.r;
z_div(&z__14, &c_b48, &rk2);
z__8.r = z__9.r + z__14.r, z__8.i = z__9.i + z__14.i;
z__2.r = z__3.r * z__8.r - z__3.i * z__8.i, z__2.i = z__3.r * z__8.i +
z__3.i * z__8.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x7.r = z__1.r, x7.i = z__1.i;
/*< ERH=( X1- X2- X4- X5+ X6+ X7)* ECON >*/
z__6.r = x1.r - x2.r, z__6.i = x1.i - x2.i;
z__5.r = z__6.r - x4.r, z__5.i = z__6.i - x4.i;
z__4.r = z__5.r - x5.r, z__4.i = z__5.i - x5.i;
z__3.r = z__4.r + x6.r, z__3.i = z__4.i + x6.i;
z__2.r = z__3.r + x7.r, z__2.i = z__3.i + x7.i;
z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i +
z__2.i * econ->r;
erh->r = z__1.r, erh->i = z__1.i;
/*< X1= XR1 >*/
x1.r = xr1.r, x1.i = xr1.i;
/*< X2= RH* XR2 >*/
z__1.r = rh.r * xr2.r - rh.i * xr2.i, z__1.i = rh.r * xr2.i + rh.i *
xr2.r;
x2.r = z__1.r, x2.i = z__1.i;
/*< X3=( RH+1.)* G* XR2 >*/
z__3.r = rh.r + 1., z__3.i = rh.i;
z__2.r = z__3.r * g.r - z__3.i * g.i, z__2.i = z__3.r * g.i + z__3.i *
g.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x3.r = z__1.r, x3.i = z__1.i;
/*< X4= T3* XR1 >*/
z__1.r = t3.r * xr1.r - t3.i * xr1.i, z__1.i = t3.r * xr1.i + t3.i *
xr1.r;
x4.r = z__1.r, x4.i = z__1.i;
/*< X5= T4*(1.- U2*(1.+ RV)- U2* OMR* F)* XR2 >*/
z__6.r = rv.r + 1., z__6.i = rv.i;
z__5.r = gwav_1.u2.r * z__6.r - gwav_1.u2.i * z__6.i, z__5.i =
gwav_1.u2.r * z__6.i + gwav_1.u2.i * z__6.r;
z__4.r = 1. - z__5.r, z__4.i = -z__5.i;
z__8.r = gwav_1.u2.r * omr.r - gwav_1.u2.i * omr.i, z__8.i = gwav_1.u2.r *
omr.i + gwav_1.u2.i * omr.r;
z__7.r = z__8.r * f.r - z__8.i * f.i, z__7.i = z__8.r * f.i + z__8.i *
f.r;
z__3.r = z__4.r - z__7.r, z__3.i = z__4.i - z__7.i;
z__2.r = t4.r * z__3.r - t4.i * z__3.i, z__2.i = t4.r * z__3.i + t4.i *
z__3.r;
z__1.r = z__2.r * xr2.r - z__2.i * xr2.i, z__1.i = z__2.r * xr2.i +
z__2.i * xr2.r;
x5.r = z__1.r, x5.i = z__1.i;
/*< X6=.5* U2* OMR*( F*( U2* T1- SPP2-1./ RK2)+1./ RK2)* XR2/ RK2 >*/
z__5.r = gwav_1.u2.r * .5, z__5.i = gwav_1.u2.i * .5;
z__4.r = z__5.r * omr.r - z__5.i * omr.i, z__4.i = z__5.r * omr.i +
z__5.i * omr.r;
z__10.r = gwav_1.u2.r * t1.r - gwav_1.u2.i * t1.i, z__10.i = gwav_1.u2.r *
t1.i + gwav_1.u2.i * t1.r;
z__9.r = z__10.r - spp2, z__9.i = z__10.i;
z_div(&z__11, &c_b48, &rk2);
z__8.r = z__9.r - z__11.r, z__8.i = z__9.i - z__11.i;
z__7.r = f.r * z__8.r - f.i * z__8.i, z__7.i = f.r * z__8.i + f.i *
z__8.r;
z_div(&z__12, &c_b48, &rk2);
z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i;
z__3.r = z__4.r * z__6.r - z__4.i * z__6.i, z__3.i = z__4.r * z__6.i +
z__4.i * z__6.r;
z__2.r = z__3.r * xr2.r - z__3.i * xr2.i, z__2.i = z__3.r * xr2.i +
z__3.i * xr2.r;
z_div(&z__1, &z__2, &rk2);
x6.r = z__1.r, x6.i = z__1.i;
/*< EPH=-( X1- X2+ X3- X4+ X5+ X6)* ECON >*/
z__7.r = x1.r - x2.r, z__7.i = x1.i - x2.i;
z__6.r = z__7.r + x3.r, z__6.i = z__7.i + x3.i;
z__5.r = z__6.r - x4.r, z__5.i = z__6.i - x4.i;
z__4.r = z__5.r + x5.r, z__4.i = z__5.i + x5.i;
z__3.r = z__4.r + x6.r, z__3.i = z__4.i + x6.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__1.r = z__2.r * econ->r - z__2.i * econ->i, z__1.i = z__2.r * econ->i +
z__2.i * econ->r;
eph->r = z__1.r, eph->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gwave_ */
#undef tpj
#undef fjx
#undef fj
#undef econx
#undef tpjx
#undef econ
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE GX( ZZ, RH, XK, GZ, GZP) >*/
/* Subroutine */ int gx_(zz, rh, xk, gz, gzp)
doublereal *zz, *rh, *xk;
doublecomplex *gz, *gzp;
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(), cos(), sin();
/* Local variables */
static doublereal r, r2, rkz;
/* *** */
/* SEGMENT END CONTRIBUTIONS FOR THIN WIRE APPROX. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX GZ, GZP >*/
/*< R2= ZZ* ZZ+ RH* RH >*/
r2 = *zz * *zz + *rh * *rh;
/*< R= SQRT( R2) >*/
r = sqrt(r2);
/*< RKZ= XK* R >*/
rkz = *xk * r;
/*< GZ= CMPLX( COS( RKZ),- SIN( RKZ))/ R >*/
d__1 = cos(rkz);
d__2 = -sin(rkz);
z__2.r = d__1, z__2.i = d__2;
z__1.r = z__2.r / r, z__1.i = z__2.i / r;
gz->r = z__1.r, gz->i = z__1.i;
/*< GZP=- CMPLX(1.0, RKZ)* GZ/ R2 >*/
z__4.r = 1., z__4.i = rkz;
z__3.r = -z__4.r, z__3.i = -z__4.i;
z__2.r = z__3.r * gz->r - z__3.i * gz->i, z__2.i = z__3.r * gz->i +
z__3.i * gz->r;
z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
gzp->r = z__1.r, gzp->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gx_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int gxx_(zz, rh, a, a2, xk, ira, g1, g1p, g2, g2p, g3, gzp)
doublereal *zz, *rh, *a, *a2, *xk;
integer *ira;
doublecomplex *g1, *g1p, *g2, *g2p, *g3, *gzp;
{
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(), cos(), sin();
/* Local variables */
static doublereal r;
static doublecomplex c1, c2, c3;
static doublereal r2, t1, r4, t2, rk;
static doublecomplex gz;
static doublereal rh2, rk2;
/* *** */
/* SEGMENT END CONTRIBUTIONS FOR EXT. THIN WIRE APPROX. */
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX GZ, C1, C2, C3, G1, G1P, G2, G2P, G3, GZP >*/
/*< R2= ZZ* ZZ+ RH* RH >*/
r2 = *zz * *zz + *rh * *rh;
/*< R= SQRT( R2) >*/
r = sqrt(r2);
/*< R4= R2* R2 >*/
r4 = r2 * r2;
/*< RK= XK* R >*/
rk = *xk * r;
/*< RK2= RK* RK >*/
rk2 = rk * rk;
/*< RH2= RH* RH >*/
rh2 = *rh * *rh;
/*< T1=.25* A2* RH2/ R4 >*/
d__1 = *a2 * .25;
t1 = d__1 * rh2 / r4;
/*< T2=.5* A2/ R2 >*/
t2 = *a2 * .5 / r2;
/*< C1= CMPLX(1.0, RK) >*/
z__1.r = 1., z__1.i = rk;
c1.r = z__1.r, c1.i = z__1.i;
/*< C2=3.* C1- RK2 >*/
z__2.r = c1.r * 3., z__2.i = c1.i * 3.;
z__1.r = z__2.r - rk2, z__1.i = z__2.i;
c2.r = z__1.r, c2.i = z__1.i;
/*< C3= CMPLX(6.0, RK)* RK2-15.* C1 >*/
z__3.r = 6., z__3.i = rk;
z__2.r = rk2 * z__3.r, z__2.i = rk2 * z__3.i;
z__4.r = c1.r * 15., z__4.i = c1.i * 15.;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
c3.r = z__1.r, c3.i = z__1.i;
/*< GZ= CMPLX( COS( RK),- SIN( RK))/ R >*/
d__1 = cos(rk);
d__2 = -sin(rk);
z__2.r = d__1, z__2.i = d__2;
z__1.r = z__2.r / r, z__1.i = z__2.i / r;
gz.r = z__1.r, gz.i = z__1.i;
/*< G2= GZ*(1.+ T1* C2) >*/
z__3.r = t1 * c2.r, z__3.i = t1 * c2.i;
z__2.r = z__3.r + 1., z__2.i = z__3.i;
z__1.r = gz.r * z__2.r - gz.i * z__2.i, z__1.i = gz.r * z__2.i + gz.i *
z__2.r;
g2->r = z__1.r, g2->i = z__1.i;
/*< G1= G2- T2* C1* GZ >*/
z__3.r = t2 * c1.r, z__3.i = t2 * c1.i;
z__2.r = z__3.r * gz.r - z__3.i * gz.i, z__2.i = z__3.r * gz.i + z__3.i *
gz.r;
z__1.r = g2->r - z__2.r, z__1.i = g2->i - z__2.i;
g1->r = z__1.r, g1->i = z__1.i;
/*< GZ= GZ/ R2 >*/
z__1.r = gz.r / r2, z__1.i = gz.i / r2;
gz.r = z__1.r, gz.i = z__1.i;
/*< G2P= GZ*( T1* C3- C1) >*/
z__3.r = t1 * c3.r, z__3.i = t1 * c3.i;
z__2.r = z__3.r - c1.r, z__2.i = z__3.i - c1.i;
z__1.r = gz.r * z__2.r - gz.i * z__2.i, z__1.i = gz.r * z__2.i + gz.i *
z__2.r;
g2p->r = z__1.r, g2p->i = z__1.i;
/*< GZP= T2* C2* GZ >*/
z__2.r = t2 * c2.r, z__2.i = t2 * c2.i;
z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i *
gz.r;
gzp->r = z__1.r, gzp->i = z__1.i;
/*< G3= G2P+ GZP >*/
z__1.r = g2p->r + gzp->r, z__1.i = g2p->i + gzp->i;
g3->r = z__1.r, g3->i = z__1.i;
/*< G1P= G3* ZZ >*/
z__1.r = *zz * g3->r, z__1.i = *zz * g3->i;
g1p->r = z__1.r, g1p->i = z__1.i;
/*< IF( IRA.EQ.1) GOTO 2 >*/
if (*ira == 1) {
goto L2;
}
/*< G3=( G3+ GZP)* RH >*/
z__2.r = g3->r + gzp->r, z__2.i = g3->i + gzp->i;
z__1.r = *rh * z__2.r, z__1.i = *rh * z__2.i;
g3->r = z__1.r, g3->i = z__1.i;
/*< GZP=- ZZ* C1* GZ >*/
d__1 = -(*zz);
z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i *
gz.r;
gzp->r = z__1.r, gzp->i = z__1.i;
/*< IF( RH.GT.1.D-10) GOTO 1 >*/
if (*rh > 1e-10) {
goto L1;
}
/*< G2=0. >*/
g2->r = 0., g2->i = 0.;
/*< G2P=0. >*/
g2p->r = 0., g2p->i = 0.;
/*< RETURN >*/
return 0;
/*< 1 G2= G2/ RH >*/
L1:
z__1.r = g2->r / *rh, z__1.i = g2->i / *rh;
g2->r = z__1.r, g2->i = z__1.i;
/*< G2P= G2P* ZZ/ RH >*/
z__2.r = *zz * g2p->r, z__2.i = *zz * g2p->i;
z__1.r = z__2.r / *rh, z__1.i = z__2.i / *rh;
g2p->r = z__1.r, g2p->i = z__1.i;
/*< RETURN >*/
return 0;
/*< 2 T2=.5* A >*/
L2:
t2 = *a * .5;
/*< G2=- T2* C1* GZ >*/
d__1 = -t2;
z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i *
gz.r;
g2->r = z__1.r, g2->i = z__1.i;
/*< G2P= T2* GZ* C2/ R2 >*/
z__3.r = t2 * gz.r, z__3.i = t2 * gz.i;
z__2.r = z__3.r * c2.r - z__3.i * c2.i, z__2.i = z__3.r * c2.i + z__3.i *
c2.r;
z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
g2p->r = z__1.r, g2p->i = z__1.i;
/*< G3= RH2* G2P- A* GZ* C1 >*/
z__2.r = rh2 * g2p->r, z__2.i = rh2 * g2p->i;
z__4.r = *a * gz.r, z__4.i = *a * gz.i;
z__3.r = z__4.r * c1.r - z__4.i * c1.i, z__3.i = z__4.r * c1.i + z__4.i *
c1.r;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
g3->r = z__1.r, g3->i = z__1.i;
/*< G2P= G2P* ZZ >*/
z__1.r = *zz * g2p->r, z__1.i = *zz * g2p->i;
g2p->r = z__1.r, g2p->i = z__1.i;
/*< GZP=- ZZ* C1* GZ >*/
d__1 = -(*zz);
z__2.r = d__1 * c1.r, z__2.i = d__1 * c1.i;
z__1.r = z__2.r * gz.r - z__2.i * gz.i, z__1.i = z__2.r * gz.i + z__2.i *
gz.r;
gzp->r = z__1.r, gzp->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* gxx_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE HELIX( S, HL, A1, B1, A2, B2, RAD, NS, ITG) >*/
/* Subroutine */ int helix_(s, hl, a1, b1, a2, b2, rad, ns, itg)
doublereal *s, *hl, *a1, *b1, *a2, *b2, *rad;
integer *ns, *itg;
{
/* Initialized data */
static doublereal pi = 3.1415926;
/* Format strings */
static char fmt_104[] = "(5x,\002THE CONE ANGLE OF THE SPIRAL IS\002,f10\
.4)";
static char fmt_105[] = "(5x,\002THE PITCH ANGLE IS\002,f10.4/5x,\002THE\
LENGTH OF WIRE/TURN 'IS\002,f10.4)";
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Builtin functions */
double cos(), sin(), atan();
integer s_wsfe(), do_fio(), e_wsfe();
double sqrt();
/* Local variables */
static doublereal hdia, hmaj, hmin, zinc, copy, turn;
static integer i;
static doublereal pitch;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal turns, sangle;
static integer ist;
/* Fortran I/O blocks */
static cilist io___1111 = { 0, 6, 0, fmt_104, 0 };
static cilist io___1117 = { 0, 6, 0, fmt_105, 0 };
/* *** */
/* SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
*/
/* SEGMENTS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< DIMENSION X2(1), Y2(1), Z2(1) >*/
/*< EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
/*< DATA PI/3.1415926D+0/ >*/
/*< IST= N+1 >*/
ist = data_1.n + 1;
/*< N= N+ NS >*/
data_1.n += *ns;
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< IF( NS.LT.1) RETURN >*/
if (*ns < 1) {
return 0;
}
/*< TURNS= ABS( HL/ S) >*/
turns = (d__1 = *hl / *s, abs(d__1));
/*< ZINC= ABS( HL/ NS) >*/
zinc = (d__1 = *hl / *ns, abs(d__1));
/*< Z( IST)=0. >*/
data_1.z[ist - 1] = 0.;
/*< DO 25 I= IST, N >*/
i__1 = data_1.n;
for (i = ist; i <= i__1; ++i) {
/*< BI( I)= RAD >*/
data_1.bi[i - 1] = *rad;
/*< ITAG( I)= ITG >*/
data_1.itag[i - 1] = *itg;
/*< IF( I.NE. IST) Z( I)= Z( I-1)+ ZINC >*/
if (i != ist) {
data_1.z[i - 1] = data_1.z[i - 2] + zinc;
}
/*< Z2( I)= Z( I)+ ZINC >*/
z2[i - 1] = data_1.z[i - 1] + zinc;
/*< IF( A2.NE. A1) GOTO 10 >*/
if (*a2 != *a1) {
goto L10;
}
/*< IF( B1.EQ.0) B1= A1 >*/
if (*b1 == 0.) {
*b1 = *a1;
}
/*< X( I)= A1* COS(2.* PI* Z( I)/ S) >*/
d__1 = pi * 2.;
data_1.x[i - 1] = *a1 * cos(d__1 * data_1.z[i - 1] / *s);
/*< Y( I)= B1* SIN(2.* PI* Z( I)/ S) >*/
d__1 = pi * 2.;
data_1.y[i - 1] = *b1 * sin(d__1 * data_1.z[i - 1] / *s);
/*< X2( I)= A1* COS(2.* PI* Z2( I)/ S) >*/
d__1 = pi * 2.;
x2[i - 1] = *a1 * cos(d__1 * z2[i - 1] / *s);
/*< Y2( I)= B1* SIN(2.* PI* Z2( I)/ S) >*/
d__1 = pi * 2.;
y2[i - 1] = *b1 * sin(d__1 * z2[i - 1] / *s);
/*< GOTO 20 >*/
goto L20;
/*< 10 IF( B2.EQ.0) B2= A2 >*/
L10:
if (*b2 == 0.) {
*b2 = *a2;
}
/*< X( I)=( A1+( A2- A1)* Z( I)/ ABS( HL))* COS(2.* PI* Z( I)/ S) >*/
d__1 = pi * 2.;
data_1.x[i - 1] = (*a1 + (*a2 - *a1) * data_1.z[i - 1] / abs(*hl)) *
cos(d__1 * data_1.z[i - 1] / *s);
/*< Y( I)=( B1+( B2- B1)* Z( I)/ ABS( HL))* SIN(2.* PI* Z( I)/ S) >*/
d__1 = pi * 2.;
data_1.y[i - 1] = (*b1 + (*b2 - *b1) * data_1.z[i - 1] / abs(*hl)) *
sin(d__1 * data_1.z[i - 1] / *s);
/*< X2( I)=( A1+( A2- A1)* Z2( I)/ ABS( HL))* COS(2.* PI* Z2( I)/ S) >*/
d__1 = pi * 2.;
x2[i - 1] = (*a1 + (*a2 - *a1) * z2[i - 1] / abs(*hl)) * cos(d__1 *
z2[i - 1] / *s);
/*< Y2( I)=( B1+( B2- B1)* Z2( I)/ ABS( HL))* SIN(2.* PI* Z2( I)/ S) >*/
d__1 = pi * 2.;
y2[i - 1] = (*b1 + (*b2 - *b1) * z2[i - 1] / abs(*hl)) * sin(d__1 *
z2[i - 1] / *s);
/*< 20 IF( HL.GT.0) GOTO 25 >*/
L20:
if (*hl > 0.) {
goto L25;
}
/*< COPY= X( I) >*/
copy = data_1.x[i - 1];
/*< X( I)= Y( I) >*/
data_1.x[i - 1] = data_1.y[i - 1];
/*< Y( I)= COPY >*/
data_1.y[i - 1] = copy;
/*< COPY= X2( I) >*/
copy = x2[i - 1];
/*< X2( I)= Y2( I) >*/
x2[i - 1] = y2[i - 1];
/*< Y2( I)= COPY >*/
y2[i - 1] = copy;
/*< 25 CONTINUE >*/
L25:
;
}
/*< IF( A2.EQ. A1) GOTO 21 >*/
if (*a2 == *a1) {
goto L21;
}
/*< SANGLE= ATAN( A2/( ABS( HL)+( ABS( HL)* A1)/( A2- A1))) >*/
sangle = atan(*a2 / (abs(*hl) + abs(*hl) * *a1 / (*a2 - *a1)));
/*< WRITE( 6,104) SANGLE >*/
s_wsfe(&io___1111);
do_fio(&c__1, (char *)&sangle, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4) >*/
/*< RETURN >*/
return 0;
/*< 21 IF( A1.NE. B1) GOTO 30 >*/
L21:
if (*a1 != *b1) {
goto L30;
}
/*< HDIA=2.* A1 >*/
hdia = *a1 * 2.;
/*< TURN= HDIA* PI >*/
turn = hdia * pi;
/*< PITCH= ATAN( S/( PI* HDIA)) >*/
pitch = atan(*s / (pi * hdia));
/*< TURN= TURN/ COS( PITCH) >*/
turn /= cos(pitch);
/*< PITCH=180.* PITCH/ PI >*/
pitch = pitch * 180. / pi;
/*< GOTO 40 >*/
goto L40;
/*< 30 IF( A1.LT. B1) GOTO 34 >*/
L30:
if (*a1 < *b1) {
goto L34;
}
/*< HMAJ=2.* A1 >*/
hmaj = *a1 * 2.;
/*< HMIN=2.* B1 >*/
hmin = *b1 * 2.;
/*< GOTO 35 >*/
goto L35;
/*< 34 HMAJ=2.* B1 >*/
L34:
hmaj = *b1 * 2.;
/*< HMIN=2.* A1 >*/
hmin = *a1 * 2.;
/*< 35 HDIA= SQRT(( HMAJ**2+ HMIN**2)/2* HMAJ) >*/
L35:
/* Computing 2nd power */
d__1 = hmaj;
/* Computing 2nd power */
d__2 = hmin;
hdia = sqrt((d__1 * d__1 + d__2 * d__2) / 2 * hmaj);
/*< TURN=2.* PI* HDIA >*/
d__1 = pi * 2.;
turn = d__1 * hdia;
/*< PITCH=(180./ PI)* ATAN( S/( PI* HDIA)) >*/
pitch = 180. / pi * atan(*s / (pi * hdia));
/*< 40 WRITE( 6,105) PITCH, TURN >*/
L40:
s_wsfe(&io___1117);
do_fio(&c__1, (char *)&pitch, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&turn, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< >*/
/*< RETURN >*/
return 0;
/*< END >*/
} /* helix_ */
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE HFK( EL1, EL2, RHK, ZPKX, SGR, SGI) >*/
/* Subroutine */ int hfk_(el1, el2, rhk, zpkx, sgr, sgi)
doublereal *el1, *el2, *rhk, *zpkx, *sgr, *sgi;
{
/* Initialized data */
static integer nx = 1;
static integer nm = 65536;
static integer nts = 4;
static doublereal rx = 1e-4;
/* Format strings */
static char fmt_18[] = "(\002 STEP SIZE LIMITED AT Z=\002,f10.5)";
/* System generated locals */
doublereal d__1;
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static doublereal zend;
extern /* Subroutine */ int test_();
static doublereal dzot, s, z;
extern /* Subroutine */ int gh_();
static doublereal ep, dz, ze;
static integer ns, nt;
static doublereal zp, g1i, g3i, g5i, g2i, g4i, g1r, g2r, g3r, g4r, g5r,
t00i, t01i, t10i, t02i, t11i, t20i, t00r, t01r, t10r, t02r, t11r,
t20r, te1i, te2i, te1r, te2r;
/* Fortran I/O blocks */
static cilist io___1158 = { 0, 6, 0, fmt_18, 0 };
/* *** */
/* HFK COMPUTES THE H FIELD OF A UNIFORM CURRENT FILAMENT BY */
/* NUMERICAL INTEGRATION */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMMON /TMH/ ZPK, RHKS >*/
/*< DATA NX, NM, NTS, RX/1,65536,4,1.D-4/ >*/
/*< ZPK= ZPKX >*/
tmh_1.zpk = *zpkx;
/*< RHKS= RHK* RHK >*/
tmh_1.rhks = *rhk * *rhk;
/*< Z= EL1 >*/
z = *el1;
/*< ZE= EL2 >*/
ze = *el2;
/*< S= ZE- Z >*/
s = ze - z;
/*< EP= S/(10.* NM) >*/
ep = s / (nm * 10.);
/*< ZEND= ZE- EP >*/
zend = ze - ep;
/*< SGR=0.0 >*/
*sgr = 0.;
/*< SGI=0.0 >*/
*sgi = 0.;
/*< NS= NX >*/
ns = nx;
/*< NT=0 >*/
nt = 0;
/*< CALL GH( Z, G1R, G1I) >*/
gh_(&z, &g1r, &g1i);
/*< 1 DZ= S/ NS >*/
L1:
dz = s / ns;
/*< ZP= Z+ DZ >*/
zp = z + dz;
/*< IF( ZP- ZE) 3,3,2 >*/
if (zp - ze <= 0.) {
goto L3;
} else {
goto L2;
}
/*< 2 DZ= ZE- Z >*/
L2:
dz = ze - z;
/*< IF( ABS( DZ)- EP) 17,17,3 >*/
if (abs(dz) - ep <= 0.) {
goto L17;
} else {
goto L3;
}
/*< 3 DZOT= DZ*.5 >*/
L3:
dzot = dz * .5;
/*< ZP= Z+ DZOT >*/
zp = z + dzot;
/*< CALL GH( ZP, G3R, G3I) >*/
gh_(&zp, &g3r, &g3i);
/*< ZP= Z+ DZ >*/
zp = z + dz;
/*< CALL GH( ZP, G5R, G5I) >*/
gh_(&zp, &g5r, &g5i);
/*< 4 T00R=( G1R+ G5R)* DZOT >*/
L4:
t00r = (g1r + g5r) * dzot;
/*< T00I=( G1I+ G5I)* DZOT >*/
t00i = (g1i + g5i) * dzot;
/*< T01R=( T00R+ DZ* G3R)*0.5 >*/
t01r = (t00r + dz * g3r) * .5;
/*< T01I=( T00I+ DZ* G3I)*0.5 >*/
t01i = (t00i + dz * g3i) * .5;
/*< T10R=(4.0* T01R- T00R)/3.0 >*/
t10r = (t01r * 4. - t00r) / 3.;
/*< T10I=(4.0* T01I- T00I)/3.0 >*/
t10i = (t01i * 4. - t00i) / 3.;
/*< CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.) >*/
test_(&t01r, &t10r, &te1r, &t01i, &t10i, &te1i, &c_b594);
/*< IF( TE1I- RX) 5,5,6 >*/
if (te1i - rx <= 0.) {
goto L5;
} else {
goto L6;
}
/*< 5 IF( TE1R- RX) 8,8,6 >*/
L5:
if (te1r - rx <= 0.) {
goto L8;
} else {
goto L6;
}
/*< 6 ZP= Z+ DZ*0.25 >*/
L6:
zp = z + dz * .25;
/*< CALL GH( ZP, G2R, G2I) >*/
gh_(&zp, &g2r, &g2i);
/*< ZP= Z+ DZ*0.75 >*/
zp = z + dz * .75;
/*< CALL GH( ZP, G4R, G4I) >*/
gh_(&zp, &g4r, &g4i);
/*< T02R=( T01R+ DZOT*( G2R+ G4R))*0.5 >*/
t02r = (t01r + dzot * (g2r + g4r)) * .5;
/*< T02I=( T01I+ DZOT*( G2I+ G4I))*0.5 >*/
t02i = (t01i + dzot * (g2i + g4i)) * .5;
/*< T11R=(4.0* T02R- T01R)/3.0 >*/
t11r = (t02r * 4. - t01r) / 3.;
/*< T11I=(4.0* T02I- T01I)/3.0 >*/
t11i = (t02i * 4. - t01i) / 3.;
/*< T20R=(16.0* T11R- T10R)/15.0 >*/
t20r = (t11r * 16. - t10r) / 15.;
/*< T20I=(16.0* T11I- T10I)/15.0 >*/
t20i = (t11i * 16. - t10i) / 15.;
/*< CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.) >*/
test_(&t11r, &t20r, &te2r, &t11i, &t20i, &te2i, &c_b594);
/*< IF( TE2I- RX) 7,7,14 >*/
if (te2i - rx <= 0.) {
goto L7;
} else {
goto L14;
}
/*< 7 IF( TE2R- RX) 9,9,14 >*/
L7:
if (te2r - rx <= 0.) {
goto L9;
} else {
goto L14;
}
/*< 8 SGR= SGR+ T10R >*/
L8:
*sgr += t10r;
/*< SGI= SGI+ T10I >*/
*sgi += t10i;
/*< NT= NT+2 >*/
nt += 2;
/*< GOTO 10 >*/
goto L10;
/*< 9 SGR= SGR+ T20R >*/
L9:
*sgr += t20r;
/*< SGI= SGI+ T20I >*/
*sgi += t20i;
/*< NT= NT+1 >*/
++nt;
/*< 10 Z= Z+ DZ >*/
L10:
z += dz;
/*< IF( Z- ZEND) 11,17,17 >*/
if (z - zend >= 0.) {
goto L17;
} else {
goto L11;
}
/*< 11 G1R= G5R >*/
L11:
g1r = g5r;
/*< G1I= G5I >*/
g1i = g5i;
/*< IF( NT- NTS) 1,12,12 >*/
if (nt - nts >= 0) {
goto L12;
} else {
goto L1;
}
/*< 12 IF( NS- NX) 1,1,13 >*/
L12:
if (ns - nx <= 0) {
goto L1;
} else {
goto L13;
}
/*< 13 NS= NS/2 >*/
L13:
ns /= 2;
/*< NT=1 >*/
nt = 1;
/*< GOTO 1 >*/
goto L1;
/*< 14 NT=0 >*/
L14:
nt = 0;
/*< IF( NS- NM) 16,15,15 >*/
if (ns - nm >= 0) {
goto L15;
} else {
goto L16;
}
/*< 15 WRITE( 6,18) Z >*/
L15:
s_wsfe(&io___1158);
do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 9 >*/
goto L9;
/*< 16 NS= NS*2 >*/
L16:
ns <<= 1;
/*< DZ= S/ NS >*/
dz = s / ns;
/*< DZOT= DZ*0.5 >*/
dzot = dz * .5;
/*< G5R= G3R >*/
g5r = g3r;
/*< G5I= G3I >*/
g5i = g3i;
/*< G3R= G2R >*/
g3r = g2r;
/*< G3I= G2I >*/
g3i = g2i;
/*< GOTO 4 >*/
goto L4;
/*< 17 CONTINUE >*/
L17:
/*< SGR= SGR* RHK*.5 >*/
d__1 = *sgr * *rhk;
*sgr = d__1 * .5;
/*< SGI= SGI* RHK*.5 >*/
d__1 = *sgi * *rhk;
*sgi = d__1 * .5;
/*< RETURN >*/
return 0;
/*< 18 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5) >*/
/*< END >*/
} /* hfk_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE HINTG( XI, YI, ZI) >*/
/* Subroutine */ int hintg_(xi, yi, zi)
doublereal *xi, *yi, *zi;
{
/* Initialized data */
static doublereal fpi = 12.56637062;
static doublereal tp = 6.283185308;
/* System generated locals */
integer i__1;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
double sqrt(), cos(), sin();
void z_sqrt(), z_div();
/* Local variables */
static doublereal t1zr, t2zr, r, xymag, cr;
static integer ip;
static doublereal rk, sr, px, rx, ry, rz, py;
static doublecomplex f1x, f1y, f1z, f2x, f2y, f2z, gam;
static doublereal cth, rfl;
static doublecomplex rrh;
static doublereal rsq;
static doublecomplex rrv;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
/* *** */
/* HINTG COMPUTES THE H FIELD OF A PATCH CURRENT */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< DATA FPI/12.56637062D+0/, TP/6.283185308D+0/ >*/
/*< RX= XI- XJ >*/
rx = *xi - dataj_1.xj;
/*< RY= YI- YJ >*/
ry = *yi - dataj_1.yj;
/*< RFL=-1. >*/
rfl = -1.;
/*< EXK=(0.,0.) >*/
dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
/*< EYK=(0.,0.) >*/
dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
/*< EZK=(0.,0.) >*/
dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
/*< EXS=(0.,0.) >*/
dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
/*< EYS=(0.,0.) >*/
dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
/*< EZS=(0.,0.) >*/
dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
/*< DO 5 IP=1, KSYMP >*/
i__1 = gnd_1.ksymp;
for (ip = 1; ip <= i__1; ++ip) {
/*< RFL=- RFL >*/
rfl = -rfl;
/*< RZ= ZI- ZJ* RFL >*/
rz = *zi - dataj_1.zj * rfl;
/*< RSQ= RX* RX+ RY* RY+ RZ* RZ >*/
d__1 = rx * rx + ry * ry;
rsq = d__1 + rz * rz;
/*< IF( RSQ.LT.1.D-20) GOTO 5 >*/
if (rsq < 1e-20) {
goto L5;
}
/*< R= SQRT( RSQ) >*/
r = sqrt(rsq);
/*< RK= TP* R >*/
rk = tp * r;
/*< CR= COS( RK) >*/
cr = cos(rk);
/*< SR= SIN( RK) >*/
sr = sin(rk);
/*< GAM=-( CMPLX( CR,- SR)+ RK* CMPLX( SR, CR))/( FPI* RSQ* R)* S >*/
d__1 = -sr;
z__5.r = cr, z__5.i = d__1;
z__7.r = sr, z__7.i = cr;
z__6.r = rk * z__7.r, z__6.i = rk * z__7.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__3.r = -z__4.r, z__3.i = -z__4.i;
d__3 = fpi * rsq;
d__2 = d__3 * r;
z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
gam.r = z__1.r, gam.i = z__1.i;
/*< EXC= GAM* RX >*/
z__1.r = rx * gam.r, z__1.i = rx * gam.i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= GAM* RY >*/
z__1.r = ry * gam.r, z__1.i = ry * gam.i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= GAM* RZ >*/
z__1.r = rz * gam.r, z__1.i = rz * gam.i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< T1ZR= T1ZJ* RFL >*/
t1zr = *t1zj * rfl;
/*< T2ZR= T2ZJ* RFL >*/
t2zr = *t2zj * rfl;
/*< F1X= EYC* T1ZR- EZC* T1YJ >*/
z__2.r = t1zr * dataj_1.eyc.r, z__2.i = t1zr * dataj_1.eyc.i;
z__3.r = *t1yj * dataj_1.ezc.r, z__3.i = *t1yj * dataj_1.ezc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f1x.r = z__1.r, f1x.i = z__1.i;
/*< F1Y= EZC* T1XJ- EXC* T1ZR >*/
z__2.r = *t1xj * dataj_1.ezc.r, z__2.i = *t1xj * dataj_1.ezc.i;
z__3.r = t1zr * dataj_1.exc.r, z__3.i = t1zr * dataj_1.exc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f1y.r = z__1.r, f1y.i = z__1.i;
/*< F1Z= EXC* T1YJ- EYC* T1XJ >*/
z__2.r = *t1yj * dataj_1.exc.r, z__2.i = *t1yj * dataj_1.exc.i;
z__3.r = *t1xj * dataj_1.eyc.r, z__3.i = *t1xj * dataj_1.eyc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f1z.r = z__1.r, f1z.i = z__1.i;
/*< F2X= EYC* T2ZR- EZC* T2YJ >*/
z__2.r = t2zr * dataj_1.eyc.r, z__2.i = t2zr * dataj_1.eyc.i;
z__3.r = *t2yj * dataj_1.ezc.r, z__3.i = *t2yj * dataj_1.ezc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f2x.r = z__1.r, f2x.i = z__1.i;
/*< F2Y= EZC* T2XJ- EXC* T2ZR >*/
z__2.r = *t2xj * dataj_1.ezc.r, z__2.i = *t2xj * dataj_1.ezc.i;
z__3.r = t2zr * dataj_1.exc.r, z__3.i = t2zr * dataj_1.exc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f2y.r = z__1.r, f2y.i = z__1.i;
/*< F2Z= EXC* T2YJ- EYC* T2XJ >*/
z__2.r = *t2yj * dataj_1.exc.r, z__2.i = *t2yj * dataj_1.exc.i;
z__3.r = *t2xj * dataj_1.eyc.r, z__3.i = *t2xj * dataj_1.eyc.i;
z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
f2z.r = z__1.r, f2z.i = z__1.i;
/*< IF( IP.EQ.1) GOTO 4 >*/
if (ip == 1) {
goto L4;
}
/*< IF( IPERF.NE.1) GOTO 1 >*/
if (gnd_1.iperf != 1) {
goto L1;
}
/*< F1X=- F1X >*/
z__1.r = -f1x.r, z__1.i = -f1x.i;
f1x.r = z__1.r, f1x.i = z__1.i;
/*< F1Y=- F1Y >*/
z__1.r = -f1y.r, z__1.i = -f1y.i;
f1y.r = z__1.r, f1y.i = z__1.i;
/*< F1Z=- F1Z >*/
z__1.r = -f1z.r, z__1.i = -f1z.i;
f1z.r = z__1.r, f1z.i = z__1.i;
/*< F2X=- F2X >*/
z__1.r = -f2x.r, z__1.i = -f2x.i;
f2x.r = z__1.r, f2x.i = z__1.i;
/*< F2Y=- F2Y >*/
z__1.r = -f2y.r, z__1.i = -f2y.i;
f2y.r = z__1.r, f2y.i = z__1.i;
/*< F2Z=- F2Z >*/
z__1.r = -f2z.r, z__1.i = -f2z.i;
f2z.r = z__1.r, f2z.i = z__1.i;
/*< GOTO 4 >*/
goto L4;
/*< 1 XYMAG= SQRT( RX* RX+ RY* RY) >*/
L1:
xymag = sqrt(rx * rx + ry * ry);
/*< IF( XYMAG.GT.1.D-6) GOTO 2 >*/
if (xymag > 1e-6) {
goto L2;
}
/*< PX=0. >*/
px = 0.;
/*< PY=0. >*/
py = 0.;
/*< CTH=1. >*/
cth = 1.;
/*< RRV=(1.,0.) >*/
rrv.r = 1., rrv.i = 0.;
/*< GOTO 3 >*/
goto L3;
/*< 2 PX=- RY/ XYMAG >*/
L2:
px = -ry / xymag;
/*< PY= RX/ XYMAG >*/
py = rx / xymag;
/*< CTH= RZ/ R >*/
cth = rz / r;
/*< RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH)) >*/
z__4.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i *
gnd_1.zrati.i, z__4.i = gnd_1.zrati.r * gnd_1.zrati.i +
gnd_1.zrati.i * gnd_1.zrati.r;
d__1 = 1. - cth * cth;
z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< 3 RRH= ZRATI* CTH >*/
L3:
z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRH=( RRH- RRV)/( RRH+ RRV) >*/
z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
z_div(&z__1, &z__2, &z__3);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRV= ZRATI* RRV >*/
z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i =
gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRV=-( CTH- RRV)/( CTH+ RRV) >*/
z__3.r = cth - rrv.r, z__3.i = -rrv.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__4.r = cth + rrv.r, z__4.i = rrv.i;
z_div(&z__1, &z__2, &z__4);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< GAM=( F1X* PX+ F1Y* PY)*( RRV- RRH) >*/
z__3.r = px * f1x.r, z__3.i = px * f1x.i;
z__4.r = py * f1y.r, z__4.i = py * f1y.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i
+ z__2.i * z__5.r;
gam.r = z__1.r, gam.i = z__1.i;
/*< F1X= F1X* RRH+ GAM* PX >*/
z__2.r = f1x.r * rrh.r - f1x.i * rrh.i, z__2.i = f1x.r * rrh.i +
f1x.i * rrh.r;
z__3.r = px * gam.r, z__3.i = px * gam.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
f1x.r = z__1.r, f1x.i = z__1.i;
/*< F1Y= F1Y* RRH+ GAM* PY >*/
z__2.r = f1y.r * rrh.r - f1y.i * rrh.i, z__2.i = f1y.r * rrh.i +
f1y.i * rrh.r;
z__3.r = py * gam.r, z__3.i = py * gam.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
f1y.r = z__1.r, f1y.i = z__1.i;
/*< F1Z= F1Z* RRH >*/
z__1.r = f1z.r * rrh.r - f1z.i * rrh.i, z__1.i = f1z.r * rrh.i +
f1z.i * rrh.r;
f1z.r = z__1.r, f1z.i = z__1.i;
/*< GAM=( F2X* PX+ F2Y* PY)*( RRV- RRH) >*/
z__3.r = px * f2x.r, z__3.i = px * f2x.i;
z__4.r = py * f2y.r, z__4.i = py * f2y.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrv.r - rrh.r, z__5.i = rrv.i - rrh.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i
+ z__2.i * z__5.r;
gam.r = z__1.r, gam.i = z__1.i;
/*< F2X= F2X* RRH+ GAM* PX >*/
z__2.r = f2x.r * rrh.r - f2x.i * rrh.i, z__2.i = f2x.r * rrh.i +
f2x.i * rrh.r;
z__3.r = px * gam.r, z__3.i = px * gam.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
f2x.r = z__1.r, f2x.i = z__1.i;
/*< F2Y= F2Y* RRH+ GAM* PY >*/
z__2.r = f2y.r * rrh.r - f2y.i * rrh.i, z__2.i = f2y.r * rrh.i +
f2y.i * rrh.r;
z__3.r = py * gam.r, z__3.i = py * gam.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
f2y.r = z__1.r, f2y.i = z__1.i;
/*< F2Z= F2Z* RRH >*/
z__1.r = f2z.r * rrh.r - f2z.i * rrh.i, z__1.i = f2z.r * rrh.i +
f2z.i * rrh.r;
f2z.r = z__1.r, f2z.i = z__1.i;
/*< 4 EXK= EXK+ F1X >*/
L4:
z__1.r = dataj_1.exk.r + f1x.r, z__1.i = dataj_1.exk.i + f1x.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK+ F1Y >*/
z__1.r = dataj_1.eyk.r + f1y.r, z__1.i = dataj_1.eyk.i + f1y.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK+ F1Z >*/
z__1.r = dataj_1.ezk.r + f1z.r, z__1.i = dataj_1.ezk.i + f1z.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= EXS+ F2X >*/
z__1.r = dataj_1.exs.r + f2x.r, z__1.i = dataj_1.exs.i + f2x.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS+ F2Y >*/
z__1.r = dataj_1.eys.r + f2y.r, z__1.i = dataj_1.eys.i + f2y.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS+ F2Z >*/
z__1.r = dataj_1.ezs.r + f2z.r, z__1.i = dataj_1.ezs.i + f2z.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< 5 CONTINUE >*/
L5:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* hintg_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE HSFLD( XI, YI, ZI, AI) >*/
/* Subroutine */ int hsfld_(xi, yi, zi, ai)
doublereal *xi, *yi, *zi, *ai;
{
/* Initialized data */
static doublereal eta = 376.73;
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(), log();
void z_div(), z_sqrt();
/* Local variables */
static doublereal rmag, rhox, rhoy, rhoz, salpr, xspec, yspec;
extern /* Subroutine */ int hsflx_();
static doublereal xymag;
static doublecomplex zratx;
static integer ip;
static doublereal rh, px;
static doublecomplex qx, qy, qz;
static doublereal zp, py, rhospc;
static doublecomplex hpc;
static doublereal cth;
static doublecomplex hpk;
static doublereal rfl;
static doublecomplex hps, rrh;
static doublereal xij, yij, zij, phx, phy, phz;
static doublecomplex rrv;
/* *** */
/* HSFLD COMPUTES THE H FIELD FOR CONSTANT, SINE, AND COSINE CURRENT
*/
/* ON A SEGMENT INCLUDING GROUND EFFECTS. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< DATA ETA/376.73/ >*/
/*< XIJ= XI- XJ >*/
xij = *xi - dataj_1.xj;
/*< YIJ= YI- YJ >*/
yij = *yi - dataj_1.yj;
/*< RFL=-1. >*/
rfl = -1.;
/*< DO 7 IP=1, KSYMP >*/
i__1 = gnd_1.ksymp;
for (ip = 1; ip <= i__1; ++ip) {
/*< RFL=- RFL >*/
rfl = -rfl;
/*< SALPR= SALPJ* RFL >*/
salpr = dataj_1.salpj * rfl;
/*< ZIJ= ZI- RFL* ZJ >*/
zij = *zi - rfl * dataj_1.zj;
/*< ZP= XIJ* CABJ+ YIJ* SABJ+ ZIJ* SALPR >*/
d__1 = xij * dataj_1.cabj + yij * dataj_1.sabj;
zp = d__1 + zij * salpr;
/*< RHOX= XIJ- CABJ* ZP >*/
rhox = xij - dataj_1.cabj * zp;
/*< RHOY= YIJ- SABJ* ZP >*/
rhoy = yij - dataj_1.sabj * zp;
/*< RHOZ= ZIJ- SALPR* ZP >*/
rhoz = zij - salpr * zp;
/*< RH= SQRT( RHOX* RHOX+ RHOY* RHOY+ RHOZ* RHOZ+ AI* AI) >*/
d__2 = rhox * rhox + rhoy * rhoy;
d__1 = d__2 + rhoz * rhoz;
rh = sqrt(d__1 + *ai * *ai);
/*< IF( RH.GT.1.D-10) GOTO 1 >*/
if (rh > 1e-10) {
goto L1;
}
/*< EXK=0. >*/
dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
/*< EYK=0. >*/
dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
/*< EZK=0. >*/
dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
/*< EXS=0. >*/
dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
/*< EYS=0. >*/
dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
/*< EZS=0. >*/
dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
/*< EXC=0. >*/
dataj_1.exc.r = 0., dataj_1.exc.i = 0.;
/*< EYC=0. >*/
dataj_1.eyc.r = 0., dataj_1.eyc.i = 0.;
/*< EZC=0. >*/
dataj_1.ezc.r = 0., dataj_1.ezc.i = 0.;
/*< GOTO 7 >*/
goto L7;
/*< 1 RHOX= RHOX/ RH >*/
L1:
rhox /= rh;
/*< RHOY= RHOY/ RH >*/
rhoy /= rh;
/*< RHOZ= RHOZ/ RH >*/
rhoz /= rh;
/*< PHX= SABJ* RHOZ- SALPR* RHOY >*/
phx = dataj_1.sabj * rhoz - salpr * rhoy;
/*< PHY= SALPR* RHOX- CABJ* RHOZ >*/
phy = salpr * rhox - dataj_1.cabj * rhoz;
/*< PHZ= CABJ* RHOY- SABJ* RHOX >*/
phz = dataj_1.cabj * rhoy - dataj_1.sabj * rhox;
/*< CALL HSFLX( S, RH, ZP, HPK, HPS, HPC) >*/
hsflx_(&dataj_1.s, &rh, &zp, &hpk, &hps, &hpc);
/*< IF( IP.NE.2) GOTO 6 >*/
if (ip != 2) {
goto L6;
}
/*< IF( IPERF.EQ.1) GOTO 5 >*/
if (gnd_1.iperf == 1) {
goto L5;
}
/*< ZRATX= ZRATI >*/
zratx.r = gnd_1.zrati.r, zratx.i = gnd_1.zrati.i;
/*< RMAG= SQRT( ZP* ZP+ RH* RH) >*/
rmag = sqrt(zp * zp + rh * rh);
/* SET PARAMETERS FOR RADIAL WIRE GROUND SCREEN. */
/*< XYMAG= SQRT( XIJ* XIJ+ YIJ* YIJ) >*/
xymag = sqrt(xij * xij + yij * yij);
/*< IF( NRADL.EQ.0) GOTO 2 >*/
if (gnd_1.nradl == 0) {
goto L2;
}
/*< XSPEC=( XI* ZJ+ ZI* XJ)/( ZI+ ZJ) >*/
xspec = (*xi * dataj_1.zj + *zi * dataj_1.xj) / (*zi + dataj_1.zj);
/*< YSPEC=( YI* ZJ+ ZI* YJ)/( ZI+ ZJ) >*/
yspec = (*yi * dataj_1.zj + *zi * dataj_1.yj) / (*zi + dataj_1.zj);
/*< RHOSPC= SQRT( XSPEC* XSPEC+ YSPEC* YSPEC+ T2* T2) >*/
d__1 = xspec * xspec + yspec * yspec;
rhospc = sqrt(d__1 + gnd_1.t2 * gnd_1.t2);
/*< IF( RHOSPC.GT. SCRWL) GOTO 2 >*/
if (rhospc > gnd_1.scrwl) {
goto L2;
}
/*< RRV= T1* RHOSPC* LOG( RHOSPC/ T2) >*/
z__2.r = rhospc * gnd_1.t1.r, z__2.i = rhospc * gnd_1.t1.i;
d__1 = log(rhospc / gnd_1.t2);
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< ZRATX=( RRV* ZRATI)/( ETA* ZRATI+ RRV) >*/
z__2.r = rrv.r * gnd_1.zrati.r - rrv.i * gnd_1.zrati.i, z__2.i =
rrv.r * gnd_1.zrati.i + rrv.i * gnd_1.zrati.r;
z__4.r = eta * gnd_1.zrati.r, z__4.i = eta * gnd_1.zrati.i;
z__3.r = z__4.r + rrv.r, z__3.i = z__4.i + rrv.i;
z_div(&z__1, &z__2, &z__3);
zratx.r = z__1.r, zratx.i = z__1.i;
/* CALCULATION OF REFLECTION COEFFICIENTS WHEN GROUND IS SPECIFIED
. */
/*< 2 IF( XYMAG.GT.1.D-6) GOTO 3 >*/
L2:
if (xymag > 1e-6) {
goto L3;
}
/*< PX=0. >*/
px = 0.;
/*< PY=0. >*/
py = 0.;
/*< CTH=1. >*/
cth = 1.;
/*< RRV=(1.,0.) >*/
rrv.r = 1., rrv.i = 0.;
/*< GOTO 4 >*/
goto L4;
/*< 3 PX=- YIJ/ XYMAG >*/
L3:
px = -yij / xymag;
/*< PY= XIJ/ XYMAG >*/
py = xij / xymag;
/*< CTH= ZIJ/ RMAG >*/
cth = zij / rmag;
/*< RRV= SQRT(1.- ZRATX* ZRATX*(1.- CTH* CTH)) >*/
z__4.r = zratx.r * zratx.r - zratx.i * zratx.i, z__4.i = zratx.r *
zratx.i + zratx.i * zratx.r;
d__1 = 1. - cth * cth;
z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< 4 RRH= ZRATX* CTH >*/
L4:
z__1.r = cth * zratx.r, z__1.i = cth * zratx.i;
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRH=-( RRH- RRV)/( RRH+ RRV) >*/
z__3.r = rrh.r - rrv.r, z__3.i = rrh.i - rrv.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__4.r = rrh.r + rrv.r, z__4.i = rrh.i + rrv.i;
z_div(&z__1, &z__2, &z__4);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRV= ZRATX* RRV >*/
z__1.r = zratx.r * rrv.r - zratx.i * rrv.i, z__1.i = zratx.r * rrv.i
+ zratx.i * rrv.r;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRV=( CTH- RRV)/( CTH+ RRV) >*/
z__2.r = cth - rrv.r, z__2.i = -rrv.i;
z__3.r = cth + rrv.r, z__3.i = rrv.i;
z_div(&z__1, &z__2, &z__3);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< QY=( PHX* PX+ PHY* PY)*( RRV- RRH) >*/
d__1 = phx * px + phy * py;
z__2.r = rrv.r - rrh.r, z__2.i = rrv.i - rrh.i;
z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
qy.r = z__1.r, qy.i = z__1.i;
/*< QX= QY* PX+ PHX* RRH >*/
z__2.r = px * qy.r, z__2.i = px * qy.i;
z__3.r = phx * rrh.r, z__3.i = phx * rrh.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
qx.r = z__1.r, qx.i = z__1.i;
/*< QY= QY* PY+ PHY* RRH >*/
z__2.r = py * qy.r, z__2.i = py * qy.i;
z__3.r = phy * rrh.r, z__3.i = phy * rrh.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
qy.r = z__1.r, qy.i = z__1.i;
/*< QZ= PHZ* RRH >*/
z__1.r = phz * rrh.r, z__1.i = phz * rrh.i;
qz.r = z__1.r, qz.i = z__1.i;
/*< EXK= EXK- HPK* QX >*/
z__2.r = hpk.r * qx.r - hpk.i * qx.i, z__2.i = hpk.r * qx.i + hpk.i *
qx.r;
z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK- HPK* QY >*/
z__2.r = hpk.r * qy.r - hpk.i * qy.i, z__2.i = hpk.r * qy.i + hpk.i *
qy.r;
z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK- HPK* QZ >*/
z__2.r = hpk.r * qz.r - hpk.i * qz.i, z__2.i = hpk.r * qz.i + hpk.i *
qz.r;
z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= EXS- HPS* QX >*/
z__2.r = hps.r * qx.r - hps.i * qx.i, z__2.i = hps.r * qx.i + hps.i *
qx.r;
z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS- HPS* QY >*/
z__2.r = hps.r * qy.r - hps.i * qy.i, z__2.i = hps.r * qy.i + hps.i *
qy.r;
z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS- HPS* QZ >*/
z__2.r = hps.r * qz.r - hps.i * qz.i, z__2.i = hps.r * qz.i + hps.i *
qz.r;
z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< EXC= EXC- HPC* QX >*/
z__2.r = hpc.r * qx.r - hpc.i * qx.i, z__2.i = hpc.r * qx.i + hpc.i *
qx.r;
z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= EYC- HPC* QY >*/
z__2.r = hpc.r * qy.r - hpc.i * qy.i, z__2.i = hpc.r * qy.i + hpc.i *
qy.r;
z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= EZC- HPC* QZ >*/
z__2.r = hpc.r * qz.r - hpc.i * qz.i, z__2.i = hpc.r * qz.i + hpc.i *
qz.r;
z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< GOTO 7 >*/
goto L7;
/*< 5 EXK= EXK- HPK* PHX >*/
L5:
z__2.r = phx * hpk.r, z__2.i = phx * hpk.i;
z__1.r = dataj_1.exk.r - z__2.r, z__1.i = dataj_1.exk.i - z__2.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK- HPK* PHY >*/
z__2.r = phy * hpk.r, z__2.i = phy * hpk.i;
z__1.r = dataj_1.eyk.r - z__2.r, z__1.i = dataj_1.eyk.i - z__2.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK- HPK* PHZ >*/
z__2.r = phz * hpk.r, z__2.i = phz * hpk.i;
z__1.r = dataj_1.ezk.r - z__2.r, z__1.i = dataj_1.ezk.i - z__2.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= EXS- HPS* PHX >*/
z__2.r = phx * hps.r, z__2.i = phx * hps.i;
z__1.r = dataj_1.exs.r - z__2.r, z__1.i = dataj_1.exs.i - z__2.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS- HPS* PHY >*/
z__2.r = phy * hps.r, z__2.i = phy * hps.i;
z__1.r = dataj_1.eys.r - z__2.r, z__1.i = dataj_1.eys.i - z__2.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS- HPS* PHZ >*/
z__2.r = phz * hps.r, z__2.i = phz * hps.i;
z__1.r = dataj_1.ezs.r - z__2.r, z__1.i = dataj_1.ezs.i - z__2.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< EXC= EXC- HPC* PHX >*/
z__2.r = phx * hpc.r, z__2.i = phx * hpc.i;
z__1.r = dataj_1.exc.r - z__2.r, z__1.i = dataj_1.exc.i - z__2.i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= EYC- HPC* PHY >*/
z__2.r = phy * hpc.r, z__2.i = phy * hpc.i;
z__1.r = dataj_1.eyc.r - z__2.r, z__1.i = dataj_1.eyc.i - z__2.i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= EZC- HPC* PHZ >*/
z__2.r = phz * hpc.r, z__2.i = phz * hpc.i;
z__1.r = dataj_1.ezc.r - z__2.r, z__1.i = dataj_1.ezc.i - z__2.i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< GOTO 7 >*/
goto L7;
/*< 6 EXK= HPK* PHX >*/
L6:
z__1.r = phx * hpk.r, z__1.i = phx * hpk.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= HPK* PHY >*/
z__1.r = phy * hpk.r, z__1.i = phy * hpk.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= HPK* PHZ >*/
z__1.r = phz * hpk.r, z__1.i = phz * hpk.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS= HPS* PHX >*/
z__1.r = phx * hps.r, z__1.i = phx * hps.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= HPS* PHY >*/
z__1.r = phy * hps.r, z__1.i = phy * hps.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= HPS* PHZ >*/
z__1.r = phz * hps.r, z__1.i = phz * hps.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< EXC= HPC* PHX >*/
z__1.r = phx * hpc.r, z__1.i = phx * hpc.i;
dataj_1.exc.r = z__1.r, dataj_1.exc.i = z__1.i;
/*< EYC= HPC* PHY >*/
z__1.r = phy * hpc.r, z__1.i = phy * hpc.i;
dataj_1.eyc.r = z__1.r, dataj_1.eyc.i = z__1.i;
/*< EZC= HPC* PHZ >*/
z__1.r = phz * hpc.r, z__1.i = phz * hpc.i;
dataj_1.ezc.r = z__1.r, dataj_1.ezc.i = z__1.i;
/*< 7 CONTINUE >*/
L7:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* hsfld_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE HSFLX( S, RH, ZPX, HPK, HPS, HPC) >*/
/* Subroutine */ int hsflx_(s, rh, zpx, hpk, hps, hpc)
doublereal *s, *rh, *zpx;
doublecomplex *hpk, *hps, *hpc;
{
/* Initialized data */
static doublereal tp = 6.283185308;
static doublereal pi8 = 25.13274123;
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 1., 0. };
static struct {
doublereal e_1[3];
} equiv_1 = { 0., -6.283185308, 0. };
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
/* Builtin functions */
double cos(), sin(), sqrt();
void z_exp();
/* Local variables */
static doublecomplex cons;
#define fjkx ((doublereal *)&equiv_1)
static doublereal r1, r2;
static doublecomplex t1, t2;
static doublereal z1, z2, dh, dk;
#define fj ((doublecomplex *)&equiv_0)
static doublereal zp, rh2, cdk;
extern /* Subroutine */ int hfk_();
#define fjk ((doublecomplex *)&equiv_1)
static doublereal hki, sdk, hkr;
#define fjx ((doublereal *)&equiv_0)
static doublereal hss, rhz;
static doublecomplex ekr1, ekr2;
/* *** */
/* CALCULATES H FIELD OF SINE COSINE, AND CONSTANT CURRENT OF SEGMENT
*/
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX FJ, FJK, EKR1, EKR2, T1, T2, CONS, HPS, HPC, HPK >*/
/*< DIMENSION FJX(2), FJKX(2) >*/
/*< EQUIVALENCE(FJ,FJX),(FJK,FJKX) >*/
/*< DATA TP/6.283185308D+0/, FJX/0.,1./, FJKX/0.,-6.283185308D+0/ >*/
/*< DATA PI8/25.13274123D+0/ >*/
/*< IF( RH.LT.1.D-10) GOTO 6 >*/
if (*rh < 1e-10) {
goto L6;
}
/*< IF( ZPX.LT.0.) GOTO 1 >*/
if (*zpx < 0.) {
goto L1;
}
/*< ZP= ZPX >*/
zp = *zpx;
/*< HSS=1. >*/
hss = 1.;
/*< GOTO 2 >*/
goto L2;
/*< 1 ZP=- ZPX >*/
L1:
zp = -(*zpx);
/*< HSS=-1. >*/
hss = -1.;
/*< 2 DH=.5* S >*/
L2:
dh = *s * .5;
/*< Z1= ZP+ DH >*/
z1 = zp + dh;
/*< Z2= ZP- DH >*/
z2 = zp - dh;
/*< IF( Z2.LT.1.D-7) GOTO 3 >*/
if (z2 < 1e-7) {
goto L3;
}
/*< RHZ= RH/ Z2 >*/
rhz = *rh / z2;
/*< GOTO 4 >*/
goto L4;
/*< 3 RHZ=1. >*/
L3:
rhz = 1.;
/*< 4 DK= TP* DH >*/
L4:
dk = tp * dh;
/*< CDK= COS( DK) >*/
cdk = cos(dk);
/*< SDK= SIN( DK) >*/
sdk = sin(dk);
/*< CALL HFK(- DK, DK, RH* TP, ZP* TP, HKR, HKI) >*/
d__1 = -dk;
d__2 = *rh * tp;
d__3 = zp * tp;
hfk_(&d__1, &dk, &d__2, &d__3, &hkr, &hki);
/*< HPK= CMPLX( HKR, HKI) >*/
z__1.r = hkr, z__1.i = hki;
hpk->r = z__1.r, hpk->i = z__1.i;
/*< IF( RHZ.LT.1.D-3) GOTO 5 >*/
if (rhz < .001) {
goto L5;
}
/*< RH2= RH* RH >*/
rh2 = *rh * *rh;
/*< R1= SQRT( RH2+ Z1* Z1) >*/
r1 = sqrt(rh2 + z1 * z1);
/*< R2= SQRT( RH2+ Z2* Z2) >*/
r2 = sqrt(rh2 + z2 * z2);
/*< EKR1= EXP( FJK* R1) >*/
z__2.r = r1 * fjk->r, z__2.i = r1 * fjk->i;
z_exp(&z__1, &z__2);
ekr1.r = z__1.r, ekr1.i = z__1.i;
/*< EKR2= EXP( FJK* R2) >*/
z__2.r = r2 * fjk->r, z__2.i = r2 * fjk->i;
z_exp(&z__1, &z__2);
ekr2.r = z__1.r, ekr2.i = z__1.i;
/*< T1= Z1* EKR1/ R1 >*/
z__2.r = z1 * ekr1.r, z__2.i = z1 * ekr1.i;
z__1.r = z__2.r / r1, z__1.i = z__2.i / r1;
t1.r = z__1.r, t1.i = z__1.i;
/*< T2= Z2* EKR2/ R2 >*/
z__2.r = z2 * ekr2.r, z__2.i = z2 * ekr2.i;
z__1.r = z__2.r / r2, z__1.i = z__2.i / r2;
t2.r = z__1.r, t2.i = z__1.i;
/*< HPS=( CDK*( EKR2- EKR1)- FJ* SDK*( T2+ T1))* HSS >*/
z__4.r = ekr2.r - ekr1.r, z__4.i = ekr2.i - ekr1.i;
z__3.r = cdk * z__4.r, z__3.i = cdk * z__4.i;
z__6.r = sdk * fj->r, z__6.i = sdk * fj->i;
z__7.r = t2.r + t1.r, z__7.i = t2.i + t1.i;
z__5.r = z__6.r * z__7.r - z__6.i * z__7.i, z__5.i = z__6.r * z__7.i +
z__6.i * z__7.r;
z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i;
z__1.r = hss * z__2.r, z__1.i = hss * z__2.i;
hps->r = z__1.r, hps->i = z__1.i;
/*< HPC=- SDK*( EKR2+ EKR1)- FJ* CDK*( T2- T1) >*/
d__1 = -sdk;
z__3.r = ekr2.r + ekr1.r, z__3.i = ekr2.i + ekr1.i;
z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
z__5.r = cdk * fj->r, z__5.i = cdk * fj->i;
z__6.r = t2.r - t1.r, z__6.i = t2.i - t1.i;
z__4.r = z__5.r * z__6.r - z__5.i * z__6.i, z__4.i = z__5.r * z__6.i +
z__5.i * z__6.r;
z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
hpc->r = z__1.r, hpc->i = z__1.i;
/*< CONS=- FJ/(2.* TP* RH) >*/
z__2.r = -fj->r, z__2.i = -fj->i;
d__2 = tp * 2.;
d__1 = d__2 * *rh;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
cons.r = z__1.r, cons.i = z__1.i;
/*< HPS= CONS* HPS >*/
z__1.r = cons.r * hps->r - cons.i * hps->i, z__1.i = cons.r * hps->i +
cons.i * hps->r;
hps->r = z__1.r, hps->i = z__1.i;
/*< HPC= CONS* HPC >*/
z__1.r = cons.r * hpc->r - cons.i * hpc->i, z__1.i = cons.r * hpc->i +
cons.i * hpc->r;
hpc->r = z__1.r, hpc->i = z__1.i;
/*< RETURN >*/
return 0;
/*< 5 EKR1= CMPLX( CDK, SDK)/( Z2* Z2) >*/
L5:
z__2.r = cdk, z__2.i = sdk;
d__1 = z2 * z2;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
ekr1.r = z__1.r, ekr1.i = z__1.i;
/*< EKR2= CMPLX( CDK,- SDK)/( Z1* Z1) >*/
d__1 = -sdk;
z__2.r = cdk, z__2.i = d__1;
d__2 = z1 * z1;
z__1.r = z__2.r / d__2, z__1.i = z__2.i / d__2;
ekr2.r = z__1.r, ekr2.i = z__1.i;
/*< T1= TP*(1./ Z1-1./ Z2) >*/
d__1 = tp * (1. / z1 - 1. / z2);
t1.r = d__1, t1.i = 0.;
/*< T2= EXP( FJK* ZP)* RH/ PI8 >*/
z__4.r = zp * fjk->r, z__4.i = zp * fjk->i;
z_exp(&z__3, &z__4);
z__2.r = *rh * z__3.r, z__2.i = *rh * z__3.i;
z__1.r = z__2.r / pi8, z__1.i = z__2.i / pi8;
t2.r = z__1.r, t2.i = z__1.i;
/*< HPS= T2*( T1+( EKR1+ EKR2)* SDK)* HSS >*/
z__5.r = ekr1.r + ekr2.r, z__5.i = ekr1.i + ekr2.i;
z__4.r = sdk * z__5.r, z__4.i = sdk * z__5.i;
z__3.r = t1.r + z__4.r, z__3.i = t1.i + z__4.i;
z__2.r = t2.r * z__3.r - t2.i * z__3.i, z__2.i = t2.r * z__3.i + t2.i *
z__3.r;
z__1.r = hss * z__2.r, z__1.i = hss * z__2.i;
hps->r = z__1.r, hps->i = z__1.i;
/*< HPC= T2*(- FJ* T1+( EKR1- EKR2)* CDK) >*/
z__4.r = -fj->r, z__4.i = -fj->i;
z__3.r = z__4.r * t1.r - z__4.i * t1.i, z__3.i = z__4.r * t1.i + z__4.i *
t1.r;
z__6.r = ekr1.r - ekr2.r, z__6.i = ekr1.i - ekr2.i;
z__5.r = cdk * z__6.r, z__5.i = cdk * z__6.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__1.r = t2.r * z__2.r - t2.i * z__2.i, z__1.i = t2.r * z__2.i + t2.i *
z__2.r;
hpc->r = z__1.r, hpc->i = z__1.i;
/*< RETURN >*/
return 0;
/*< 6 HPS=(0.,0.) >*/
L6:
hps->r = 0., hps->i = 0.;
/*< HPC=(0.,0.) >*/
hpc->r = 0., hpc->i = 0.;
/*< HPK=(0.,0.) >*/
hpk->r = 0., hpk->i = 0.;
/*< RETURN >*/
return 0;
/*< END >*/
} /* hsflx_ */
#undef fjx
#undef fjk
#undef fj
#undef fjkx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE INTRP( X, Y, F1, F2, F3, F4) >*/
/* Subroutine */ int intrp_(x, y, f1, f2, f3, f4)
doublereal *x, *y;
doublecomplex *f1, *f2, *f3, *f4;
{
/* Initialized data */
static integer ixs = -10;
static integer iys = -10;
static integer igrs = -10;
static doublereal dx = 1.;
static doublereal dy = 1.;
static doublereal xs = 0.;
static doublereal ys = 0.;
static integer nda[3] = { 11,17,9 };
static integer ndpa[3] = { 110,85,72 };
static integer ixeg = 0;
static integer iyeg = 0;
/* System generated locals */
integer i__1, i__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7;
static doublecomplex equiv_15[16], equiv_31[16], equiv_47[16], equiv_63[
16];
/* Local variables */
static integer iadd, iadz, nxms, nyms;
#define a (equiv_15)
#define b (equiv_31)
#define c (equiv_47)
#define d (equiv_63)
static integer i, k;
static doublecomplex p1, p2, p3, p4;
#define a11 (equiv_15)
#define a12 (equiv_15 + 4)
#define a13 (equiv_15 + 8)
#define a14 (equiv_15 + 12)
#define a21 (equiv_15 + 1)
#define a22 (equiv_15 + 5)
#define a23 (equiv_15 + 9)
#define a24 (equiv_15 + 13)
#define a31 (equiv_15 + 2)
#define a32 (equiv_15 + 6)
#define a33 (equiv_15 + 10)
#define a34 (equiv_15 + 14)
#define a41 (equiv_15 + 3)
#define a42 (equiv_15 + 7)
#define a43 (equiv_15 + 11)
#define a44 (equiv_15 + 15)
#define b11 (equiv_31)
#define b12 (equiv_31 + 4)
#define b13 (equiv_31 + 8)
#define b14 (equiv_31 + 12)
#define b21 (equiv_31 + 1)
#define b22 (equiv_31 + 5)
#define b23 (equiv_31 + 9)
#define b24 (equiv_31 + 13)
#define b31 (equiv_31 + 2)
#define b32 (equiv_31 + 6)
#define b33 (equiv_31 + 10)
#define b34 (equiv_31 + 14)
#define b41 (equiv_31 + 3)
#define b42 (equiv_31 + 7)
#define b43 (equiv_31 + 11)
#define b44 (equiv_31 + 15)
#define c11 (equiv_47)
#define c12 (equiv_47 + 4)
#define c13 (equiv_47 + 8)
#define c14 (equiv_47 + 12)
#define c21 (equiv_47 + 1)
#define c22 (equiv_47 + 5)
#define c23 (equiv_47 + 9)
#define c24 (equiv_47 + 13)
#define c31 (equiv_47 + 2)
#define c32 (equiv_47 + 6)
#define c33 (equiv_47 + 10)
#define c34 (equiv_47 + 14)
#define c41 (equiv_47 + 3)
#define c42 (equiv_47 + 7)
#define c43 (equiv_47 + 11)
#define c44 (equiv_47 + 15)
#define d11 (equiv_63)
#define d12 (equiv_63 + 4)
#define d13 (equiv_63 + 8)
#define d14 (equiv_63 + 12)
#define d21 (equiv_63 + 1)
#define d22 (equiv_63 + 5)
#define d23 (equiv_63 + 9)
#define d24 (equiv_63 + 13)
#define d31 (equiv_63 + 2)
#define d32 (equiv_63 + 6)
#define d33 (equiv_63 + 10)
#define d34 (equiv_63 + 14)
#define d41 (equiv_63 + 3)
#define d42 (equiv_63 + 7)
#define d43 (equiv_63 + 11)
#define d44 (equiv_63 + 15)
static integer ix, iy;
static doublecomplex fx1, fx2, fx3, fx4;
static integer nd;
static doublereal xz, yz, xx, yy;
#define xs2 ((doublereal *)&ggrid_1 + 2145)
#define ys3 ((doublereal *)&ggrid_1 + 2149)
static integer igr, ndp;
#define arl1 ((doublecomplex *)&ggrid_1)
#define arl2 ((doublecomplex *)&ggrid_1 + 440)
#define arl3 ((doublecomplex *)&ggrid_1 + 780)
static integer nxm2, nym2;
/* *** */
/* INTRP USES BIVARIATE CUBIC INTERPOLATION TO OBTAIN THE VALUES OF */
/* 4 FUNCTIONS AT THE POINT (X,Y). */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMPLEX AR1, AR2, AR3, ARL1, ARL2, ARL3, EPSCF >*/
/*< >*/
/*< DIMENSION NDA(3), NDPA(3) >*/
/*< >*/
/*< EQUIVALENCE(A(1,1),A11),(A(1,2),A12),(A(1,3),A13),(A(1,4),A14) >*/
/*< EQUIVALENCE(A(2,1),A21),(A(2,2),A22),(A(2,3),A23),(A(2,4),A24) >*/
/*< EQUIVALENCE(A(3,1),A31),(A(3,2),A32),(A(3,3),A33),(A(3,4),A34) >*/
/*< EQUIVALENCE(A(4,1),A41),(A(4,2),A42),(A(4,3),A43),(A(4,4),A44) >*/
/*< EQUIVALENCE(B(1,1),B11),(B(1,2),B12),(B(1,3),B13),(B(1,4),B14) >*/
/*< EQUIVALENCE(B(2,1),B21),(B(2,2),B22),(B(2,3),B23),(B(2,4),B24) >*/
/*< EQUIVALENCE(B(3,1),B31),(B(3,2),B32),(B(3,3),B33),(B(3,4),B34) >*/
/*< EQUIVALENCE(B(4,1),B41),(B(4,2),B42),(B(4,3),B43),(B(4,4),B44) >*/
/*< EQUIVALENCE(C(1,1),C11),(C(1,2),C12),(C(1,3),C13),(C(1,4),C14) >*/
/*< EQUIVALENCE(C(2,1),C21),(C(2,2),C22),(C(2,3),C23),(C(2,4),C24) >*/
/*< EQUIVALENCE(C(3,1),C31),(C(3,2),C32),(C(3,3),C33),(C(3,4),C34) >*/
/*< EQUIVALENCE(C(4,1),C41),(C(4,2),C42),(C(4,3),C43),(C(4,4),C44) >*/
/*< EQUIVALENCE(D(1,1),D11),(D(1,2),D12),(D(1,3),D13),(D(1,4),D14) >*/
/*< EQUIVALENCE(D(2,1),D21),(D(2,2),D22),(D(2,3),D23),(D(2,4),D24) >*/
/*< EQUIVALENCE(D(3,1),D31),(D(3,2),D32),(D(3,3),D33),(D(3,4),D34) >*/
/*< EQUIVALENCE(D(4,1),D41),(D(4,2),D42),(D(4,3),D43),(D(4,4),D44) >*/
/*< >*/
/*< DATA IXS, IYS, IGRS/-10,-10,-10/, DX, DY, XS, YS/1.,1.,0.,0./ >*/
/*< DATA NDA/11,17,9/, NDPA/110,85,72/, IXEG, IYEG/0,0/ >*/
/*< IF( X.LT. XS.OR. Y.LT. YS) GOTO 1 >*/
if (*x < xs || *y < ys) {
goto L1;
}
/*< IX= INT(( X- XS)/ DX)+1 >*/
ix = (integer) ((*x - xs) / dx) + 1;
/* IF POINT LIES IN SAME 4 BY 4 POINT REGION AS PREVIOUS POINT, OLD */
/* VALUES ARE REUSED */
/*< IY= INT(( Y- YS)/ DY)+1 >*/
iy = (integer) ((*y - ys) / dy) + 1;
/*< IF( IX.LT. IXEG.OR. IY.LT. IYEG) GOTO 1 >*/
if (ix < ixeg || iy < iyeg) {
goto L1;
}
/* DETERMINE CORRECT GRID AND GRID REGION */
/*< IF( IABS( IX- IXS).LT.2.AND. IABS( IY- IYS).LT.2) GOTO 12 >*/
if ((i__1 = ix - ixs, abs(i__1)) < 2 && (i__2 = iy - iys, abs(i__2)) < 2)
{
goto L12;
}
/*< 1 IF( X.GT. XS2) GOTO 2 >*/
L1:
if (*x > *xs2) {
goto L2;
}
/*< IGR=1 >*/
igr = 1;
/*< GOTO 3 >*/
goto L3;
/*< 2 IGR=2 >*/
L2:
igr = 2;
/*< IF( Y.GT. YS3) IGR=3 >*/
if (*y > *ys3) {
igr = 3;
}
/*< 3 IF( IGR.EQ. IGRS) GOTO 4 >*/
L3:
if (igr == igrs) {
goto L4;
}
/*< IGRS= IGR >*/
igrs = igr;
/*< DX= DXA( IGRS) >*/
dx = ggrid_1.dxa[igrs - 1];
/*< DY= DYA( IGRS) >*/
dy = ggrid_1.dya[igrs - 1];
/*< XS= XSA( IGRS) >*/
xs = ggrid_1.xsa[igrs - 1];
/*< YS= YSA( IGRS) >*/
ys = ggrid_1.ysa[igrs - 1];
/*< NXM2= NXA( IGRS)-2 >*/
nxm2 = ggrid_1.nxa[igrs - 1] - 2;
/*< NYM2= NYA( IGRS)-2 >*/
nym2 = ggrid_1.nya[igrs - 1] - 2;
/*< NXMS=(( NXM2+1)/3)*3+1 >*/
nxms = (nxm2 + 1) / 3 * 3 + 1;
/*< NYMS=(( NYM2+1)/3)*3+1 >*/
nyms = (nym2 + 1) / 3 * 3 + 1;
/*< ND= NDA( IGRS) >*/
nd = nda[igrs - 1];
/*< NDP= NDPA( IGRS) >*/
ndp = ndpa[igrs - 1];
/*< IX= INT(( X- XS)/ DX)+1 >*/
ix = (integer) ((*x - xs) / dx) + 1;
/*< IY= INT(( Y- YS)/ DY)+1 >*/
iy = (integer) ((*y - ys) / dy) + 1;
/*< 4 IXS=(( IX-1)/3)*3+2 >*/
L4:
ixs = (ix - 1) / 3 * 3 + 2;
/*< IF( IXS.LT.2) IXS=2 >*/
if (ixs < 2) {
ixs = 2;
}
/*< IXEG=-10000 >*/
ixeg = -10000;
/*< IF( IXS.LE. NXM2) GOTO 5 >*/
if (ixs <= nxm2) {
goto L5;
}
/*< IXS= NXM2 >*/
ixs = nxm2;
/*< IXEG= NXMS >*/
ixeg = nxms;
/*< 5 IYS=(( IY-1)/3)*3+2 >*/
L5:
iys = (iy - 1) / 3 * 3 + 2;
/*< IF( IYS.LT.2) IYS=2 >*/
if (iys < 2) {
iys = 2;
}
/*< IYEG=-10000 >*/
iyeg = -10000;
/*< IF( IYS.LE. NYM2) GOTO 6 >*/
if (iys <= nym2) {
goto L6;
}
/*< IYS= NYM2 >*/
iys = nym2;
/* COMPUTE COEFFICIENTS OF 4 CUBIC POLYNOMIALS IN X FOR THE 4 GRID */
/* VALUES OF Y FOR EACH OF THE 4 FUNCTIONS */
/*< IYEG= NYMS >*/
iyeg = nyms;
/*< 6 IADZ= IXS+( IYS-3)* ND- NDP >*/
L6:
iadz = ixs + (iys - 3) * nd - ndp;
/*< DO 11 K=1,4 >*/
for (k = 1; k <= 4; ++k) {
/*< IADZ= IADZ+ NDP >*/
iadz += ndp;
/*< IADD= IADZ >*/
iadd = iadz;
/*< DO 11 I=1,4 >*/
for (i = 1; i <= 4; ++i) {
/*< IADD= IADD+ ND >*/
iadd += nd;
/* P1=AR1(IXS-1,IYS-2+I,K) */
/*< GOTO (7,8,9), IGRS >*/
switch ((int)(igrs)) {
case 1: goto L7;
case 2: goto L8;
case 3: goto L9;
}
/*< 7 P1= ARL1( IADD-1) >*/
L7:
i__1 = iadd - 2;
p1.r = arl1[i__1].r, p1.i = arl1[i__1].i;
/*< P2= ARL1( IADD) >*/
i__1 = iadd - 1;
p2.r = arl1[i__1].r, p2.i = arl1[i__1].i;
/*< P3= ARL1( IADD+1) >*/
i__1 = iadd;
p3.r = arl1[i__1].r, p3.i = arl1[i__1].i;
/*< P4= ARL1( IADD+2) >*/
i__1 = iadd + 1;
p4.r = arl1[i__1].r, p4.i = arl1[i__1].i;
/*< GOTO 10 >*/
goto L10;
/*< 8 P1= ARL2( IADD-1) >*/
L8:
i__1 = iadd - 2;
p1.r = arl2[i__1].r, p1.i = arl2[i__1].i;
/*< P2= ARL2( IADD) >*/
i__1 = iadd - 1;
p2.r = arl2[i__1].r, p2.i = arl2[i__1].i;
/*< P3= ARL2( IADD+1) >*/
i__1 = iadd;
p3.r = arl2[i__1].r, p3.i = arl2[i__1].i;
/*< P4= ARL2( IADD+2) >*/
i__1 = iadd + 1;
p4.r = arl2[i__1].r, p4.i = arl2[i__1].i;
/*< GOTO 10 >*/
goto L10;
/*< 9 P1= ARL3( IADD-1) >*/
L9:
i__1 = iadd - 2;
p1.r = arl3[i__1].r, p1.i = arl3[i__1].i;
/*< P2= ARL3( IADD) >*/
i__1 = iadd - 1;
p2.r = arl3[i__1].r, p2.i = arl3[i__1].i;
/*< P3= ARL3( IADD+1) >*/
i__1 = iadd;
p3.r = arl3[i__1].r, p3.i = arl3[i__1].i;
/*< P4= ARL3( IADD+2) >*/
i__1 = iadd + 1;
p4.r = arl3[i__1].r, p4.i = arl3[i__1].i;
/*< 10 A( I, K)=( P4- P1+3.*( P2- P3))*.1666666667D+0 >*/
L10:
i__1 = i + (k << 2) - 5;
z__3.r = p4.r - p1.r, z__3.i = p4.i - p1.i;
z__5.r = p2.r - p3.r, z__5.i = p2.i - p3.i;
z__4.r = z__5.r * 3., z__4.i = z__5.i * 3.;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = z__2.r * .1666666667, z__1.i = z__2.i * .1666666667;
a[i__1].r = z__1.r, a[i__1].i = z__1.i;
/*< B( I, K)=( P1-2.* P2+ P3)*.5 >*/
i__1 = i + (k << 2) - 5;
z__4.r = p2.r * 2., z__4.i = p2.i * 2.;
z__3.r = p1.r - z__4.r, z__3.i = p1.i - z__4.i;
z__2.r = z__3.r + p3.r, z__2.i = z__3.i + p3.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
b[i__1].r = z__1.r, b[i__1].i = z__1.i;
/*< C( I, K)= P3-(2.* P1+3.* P2+ P4)*.1666666667D+0 >*/
i__1 = i + (k << 2) - 5;
z__5.r = p1.r * 2., z__5.i = p1.i * 2.;
z__6.r = p2.r * 3., z__6.i = p2.i * 3.;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z__3.r = z__4.r + p4.r, z__3.i = z__4.i + p4.i;
z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
z__1.r = p3.r - z__2.r, z__1.i = p3.i - z__2.i;
c[i__1].r = z__1.r, c[i__1].i = z__1.i;
/*< 11 D( I, K)= P2 >*/
/* L11: */
i__1 = i + (k << 2) - 5;
d[i__1].r = p2.r, d[i__1].i = p2.i;
}
}
/*< XZ=( IXS-1)* DX+ XS >*/
xz = (ixs - 1) * dx + xs;
/* EVALUATE POLYMOMIALS IN X AND THEN USE CUBIC INTERPOLATION IN Y */
/* FOR EACH OF THE 4 FUNCTIONS. */
/*< YZ=( IYS-1)* DY+ YS >*/
yz = (iys - 1) * dy + ys;
/*< 12 XX=( X- XZ)/ DX >*/
L12:
xx = (*x - xz) / dx;
/*< YY=( Y- YZ)/ DY >*/
yy = (*y - yz) / dy;
/*< FX1=(( A11* XX+ B11)* XX+ C11)* XX+ D11 >*/
z__6.r = xx * a11->r, z__6.i = xx * a11->i;
z__5.r = z__6.r + b11->r, z__5.i = z__6.i + b11->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c11->r, z__3.i = z__4.i + c11->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d11->r, z__1.i = z__2.i + d11->i;
fx1.r = z__1.r, fx1.i = z__1.i;
/*< FX2=(( A21* XX+ B21)* XX+ C21)* XX+ D21 >*/
z__6.r = xx * a21->r, z__6.i = xx * a21->i;
z__5.r = z__6.r + b21->r, z__5.i = z__6.i + b21->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c21->r, z__3.i = z__4.i + c21->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d21->r, z__1.i = z__2.i + d21->i;
fx2.r = z__1.r, fx2.i = z__1.i;
/*< FX3=(( A31* XX+ B31)* XX+ C31)* XX+ D31 >*/
z__6.r = xx * a31->r, z__6.i = xx * a31->i;
z__5.r = z__6.r + b31->r, z__5.i = z__6.i + b31->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c31->r, z__3.i = z__4.i + c31->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d31->r, z__1.i = z__2.i + d31->i;
fx3.r = z__1.r, fx3.i = z__1.i;
/*< FX4=(( A41* XX+ B41)* XX+ C41)* XX+ D41 >*/
z__6.r = xx * a41->r, z__6.i = xx * a41->i;
z__5.r = z__6.r + b41->r, z__5.i = z__6.i + b41->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c41->r, z__3.i = z__4.i + c41->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d41->r, z__1.i = z__2.i + d41->i;
fx4.r = z__1.r, fx4.i = z__1.i;
/*< P1= FX4- FX1+3.*( FX2- FX3) >*/
z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
p1.r = z__1.r, p1.i = z__1.i;
/*< P2=3.*( FX1-2.* FX2+ FX3) >*/
z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
p2.r = z__1.r, p2.i = z__1.i;
/*< P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
p3.r = z__1.r, p3.i = z__1.i;
/*< F1=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
z__7.r = yy * p1.r, z__7.i = yy * p1.i;
z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
f1->r = z__1.r, f1->i = z__1.i;
/*< FX1=(( A12* XX+ B12)* XX+ C12)* XX+ D12 >*/
z__6.r = xx * a12->r, z__6.i = xx * a12->i;
z__5.r = z__6.r + b12->r, z__5.i = z__6.i + b12->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c12->r, z__3.i = z__4.i + c12->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d12->r, z__1.i = z__2.i + d12->i;
fx1.r = z__1.r, fx1.i = z__1.i;
/*< FX2=(( A22* XX+ B22)* XX+ C22)* XX+ D22 >*/
z__6.r = xx * a22->r, z__6.i = xx * a22->i;
z__5.r = z__6.r + b22->r, z__5.i = z__6.i + b22->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c22->r, z__3.i = z__4.i + c22->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d22->r, z__1.i = z__2.i + d22->i;
fx2.r = z__1.r, fx2.i = z__1.i;
/*< FX3=(( A32* XX+ B32)* XX+ C32)* XX+ D32 >*/
z__6.r = xx * a32->r, z__6.i = xx * a32->i;
z__5.r = z__6.r + b32->r, z__5.i = z__6.i + b32->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c32->r, z__3.i = z__4.i + c32->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d32->r, z__1.i = z__2.i + d32->i;
fx3.r = z__1.r, fx3.i = z__1.i;
/*< FX4=(( A42* XX+ B42)* XX+ C42)* XX+ D42 >*/
z__6.r = xx * a42->r, z__6.i = xx * a42->i;
z__5.r = z__6.r + b42->r, z__5.i = z__6.i + b42->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c42->r, z__3.i = z__4.i + c42->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d42->r, z__1.i = z__2.i + d42->i;
fx4.r = z__1.r, fx4.i = z__1.i;
/*< P1= FX4- FX1+3.*( FX2- FX3) >*/
z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
p1.r = z__1.r, p1.i = z__1.i;
/*< P2=3.*( FX1-2.* FX2+ FX3) >*/
z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
p2.r = z__1.r, p2.i = z__1.i;
/*< P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
p3.r = z__1.r, p3.i = z__1.i;
/*< F2=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
z__7.r = yy * p1.r, z__7.i = yy * p1.i;
z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
f2->r = z__1.r, f2->i = z__1.i;
/*< FX1=(( A13* XX+ B13)* XX+ C13)* XX+ D13 >*/
z__6.r = xx * a13->r, z__6.i = xx * a13->i;
z__5.r = z__6.r + b13->r, z__5.i = z__6.i + b13->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c13->r, z__3.i = z__4.i + c13->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d13->r, z__1.i = z__2.i + d13->i;
fx1.r = z__1.r, fx1.i = z__1.i;
/*< FX2=(( A23* XX+ B23)* XX+ C23)* XX+ D23 >*/
z__6.r = xx * a23->r, z__6.i = xx * a23->i;
z__5.r = z__6.r + b23->r, z__5.i = z__6.i + b23->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c23->r, z__3.i = z__4.i + c23->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d23->r, z__1.i = z__2.i + d23->i;
fx2.r = z__1.r, fx2.i = z__1.i;
/*< FX3=(( A33* XX+ B33)* XX+ C33)* XX+ D33 >*/
z__6.r = xx * a33->r, z__6.i = xx * a33->i;
z__5.r = z__6.r + b33->r, z__5.i = z__6.i + b33->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c33->r, z__3.i = z__4.i + c33->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d33->r, z__1.i = z__2.i + d33->i;
fx3.r = z__1.r, fx3.i = z__1.i;
/*< FX4=(( A43* XX+ B43)* XX+ C43)* XX+ D43 >*/
z__6.r = xx * a43->r, z__6.i = xx * a43->i;
z__5.r = z__6.r + b43->r, z__5.i = z__6.i + b43->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c43->r, z__3.i = z__4.i + c43->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d43->r, z__1.i = z__2.i + d43->i;
fx4.r = z__1.r, fx4.i = z__1.i;
/*< P1= FX4- FX1+3.*( FX2- FX3) >*/
z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
p1.r = z__1.r, p1.i = z__1.i;
/*< P2=3.*( FX1-2.* FX2+ FX3) >*/
z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
p2.r = z__1.r, p2.i = z__1.i;
/*< P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
p3.r = z__1.r, p3.i = z__1.i;
/*< F3=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
z__7.r = yy * p1.r, z__7.i = yy * p1.i;
z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
f3->r = z__1.r, f3->i = z__1.i;
/*< FX1=(( A14* XX+ B14)* XX+ C14)* XX+ D14 >*/
z__6.r = xx * a14->r, z__6.i = xx * a14->i;
z__5.r = z__6.r + b14->r, z__5.i = z__6.i + b14->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c14->r, z__3.i = z__4.i + c14->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d14->r, z__1.i = z__2.i + d14->i;
fx1.r = z__1.r, fx1.i = z__1.i;
/*< FX2=(( A24* XX+ B24)* XX+ C24)* XX+ D24 >*/
z__6.r = xx * a24->r, z__6.i = xx * a24->i;
z__5.r = z__6.r + b24->r, z__5.i = z__6.i + b24->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c24->r, z__3.i = z__4.i + c24->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d24->r, z__1.i = z__2.i + d24->i;
fx2.r = z__1.r, fx2.i = z__1.i;
/*< FX3=(( A34* XX+ B34)* XX+ C34)* XX+ D34 >*/
z__6.r = xx * a34->r, z__6.i = xx * a34->i;
z__5.r = z__6.r + b34->r, z__5.i = z__6.i + b34->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c34->r, z__3.i = z__4.i + c34->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d34->r, z__1.i = z__2.i + d34->i;
fx3.r = z__1.r, fx3.i = z__1.i;
/*< FX4=(( A44* XX+ B44)* XX+ C44)* XX+ D44 >*/
z__6.r = xx * a44->r, z__6.i = xx * a44->i;
z__5.r = z__6.r + b44->r, z__5.i = z__6.i + b44->i;
z__4.r = xx * z__5.r, z__4.i = xx * z__5.i;
z__3.r = z__4.r + c44->r, z__3.i = z__4.i + c44->i;
z__2.r = xx * z__3.r, z__2.i = xx * z__3.i;
z__1.r = z__2.r + d44->r, z__1.i = z__2.i + d44->i;
fx4.r = z__1.r, fx4.i = z__1.i;
/*< P1= FX4- FX1+3.*( FX2- FX3) >*/
z__2.r = fx4.r - fx1.r, z__2.i = fx4.i - fx1.i;
z__4.r = fx2.r - fx3.r, z__4.i = fx2.i - fx3.i;
z__3.r = z__4.r * 3., z__3.i = z__4.i * 3.;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
p1.r = z__1.r, p1.i = z__1.i;
/*< P2=3.*( FX1-2.* FX2+ FX3) >*/
z__4.r = fx2.r * 2., z__4.i = fx2.i * 2.;
z__3.r = fx1.r - z__4.r, z__3.i = fx1.i - z__4.i;
z__2.r = z__3.r + fx3.r, z__2.i = z__3.i + fx3.i;
z__1.r = z__2.r * 3., z__1.i = z__2.i * 3.;
p2.r = z__1.r, p2.i = z__1.i;
/*< P3=6.* FX3-2.* FX1-3.* FX2- FX4 >*/
z__4.r = fx3.r * 6., z__4.i = fx3.i * 6.;
z__5.r = fx1.r * 2., z__5.i = fx1.i * 2.;
z__3.r = z__4.r - z__5.r, z__3.i = z__4.i - z__5.i;
z__6.r = fx2.r * 3., z__6.i = fx2.i * 3.;
z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i;
z__1.r = z__2.r - fx4.r, z__1.i = z__2.i - fx4.i;
p3.r = z__1.r, p3.i = z__1.i;
/*< F4=(( P1* YY+ P2)* YY+ P3)* YY*.1666666667D+0+ FX2 >*/
z__7.r = yy * p1.r, z__7.i = yy * p1.i;
z__6.r = z__7.r + p2.r, z__6.i = z__7.i + p2.i;
z__5.r = yy * z__6.r, z__5.i = yy * z__6.i;
z__4.r = z__5.r + p3.r, z__4.i = z__5.i + p3.i;
z__3.r = yy * z__4.r, z__3.i = yy * z__4.i;
z__2.r = z__3.r * .1666666667, z__2.i = z__3.i * .1666666667;
z__1.r = z__2.r + fx2.r, z__1.i = z__2.i + fx2.i;
f4->r = z__1.r, f4->i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* intrp_ */
#undef arl3
#undef arl2
#undef arl1
#undef ys3
#undef xs2
#undef d44
#undef d43
#undef d42
#undef d41
#undef d34
#undef d33
#undef d32
#undef d31
#undef d24
#undef d23
#undef d22
#undef d21
#undef d14
#undef d13
#undef d12
#undef d11
#undef c44
#undef c43
#undef c42
#undef c41
#undef c34
#undef c33
#undef c32
#undef c31
#undef c24
#undef c23
#undef c22
#undef c21
#undef c14
#undef c13
#undef c12
#undef c11
#undef b44
#undef b43
#undef b42
#undef b41
#undef b34
#undef b33
#undef b32
#undef b31
#undef b24
#undef b23
#undef b22
#undef b21
#undef b14
#undef b13
#undef b12
#undef b11
#undef a44
#undef a43
#undef a42
#undef a41
#undef a34
#undef a33
#undef a32
#undef a31
#undef a24
#undef a23
#undef a22
#undef a21
#undef a14
#undef a13
#undef a12
#undef a11
#undef d
#undef c
#undef b
#undef a
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE INTX( EL1, EL2, B, IJ, SGR, SGI) >*/
/* Subroutine */ int intx_(el1, el2, b, ij, sgr, sgi)
doublereal *el1, *el2, *b;
integer *ij;
doublereal *sgr, *sgi;
{
/* Initialized data */
static integer nx = 1;
static integer nm = 65536;
static integer nts = 4;
static doublereal rx = 1e-4;
/* Format strings */
static char fmt_20[] = "(\002 STEP SIZE LIMITED AT Z=\002,f10.5)";
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
double sqrt(), log();
/* Local variables */
static doublereal zend;
extern /* Subroutine */ int test_();
static doublereal dzot, s, z;
extern /* Subroutine */ int gf_();
static doublereal ep, dz, ze;
static integer ns, nt;
static doublereal zp, g1i, g3i, g5i, g2i, g4i, g1r, g2r, g3r, g4r, g5r,
t00i, t01i, t10i, t02i, fnm, t11i, t20i, t00r, fns, t01r, t10r,
t02r, t11r, t20r, te1i, te2i, te1r, te2r;
/* Fortran I/O blocks */
static cilist io___1400 = { 0, 6, 0, fmt_20, 0 };
/* *** */
/* INTX PERFORMS NUMERICAL INTEGRATION OF EXP(JKR)/R BY THE METHOD OF
*/
/* VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION. THE INTEGRAND VALUE
*/
/* IS SUPPLIED BY SUBROUTINE GF. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< DATA NX, NM, NTS, RX/1,65536,4,1.D-4/ >*/
/*< Z= EL1 >*/
z = *el1;
/*< ZE= EL2 >*/
ze = *el2;
/*< IF( IJ.EQ.0) ZE=0. >*/
if (*ij == 0) {
ze = 0.;
}
/*< S= ZE- Z >*/
s = ze - z;
/*< FNM= NM >*/
fnm = (doublereal) nm;
/*< EP= S/(10.* FNM) >*/
ep = s / (fnm * 10.);
/*< ZEND= ZE- EP >*/
zend = ze - ep;
/*< SGR=0. >*/
*sgr = 0.;
/*< SGI=0. >*/
*sgi = 0.;
/*< NS= NX >*/
ns = nx;
/*< NT=0 >*/
nt = 0;
/*< CALL GF( Z, G1R, G1I) >*/
gf_(&z, &g1r, &g1i);
/*< 1 FNS= NS >*/
L1:
fns = (doublereal) ns;
/*< DZ= S/ FNS >*/
dz = s / fns;
/*< ZP= Z+ DZ >*/
zp = z + dz;
/*< IF( ZP- ZE) 3,3,2 >*/
if (zp - ze <= 0.) {
goto L3;
} else {
goto L2;
}
/*< 2 DZ= ZE- Z >*/
L2:
dz = ze - z;
/*< IF( ABS( DZ)- EP) 17,17,3 >*/
if (abs(dz) - ep <= 0.) {
goto L17;
} else {
goto L3;
}
/*< 3 DZOT= DZ*.5 >*/
L3:
dzot = dz * .5;
/*< ZP= Z+ DZOT >*/
zp = z + dzot;
/*< CALL GF( ZP, G3R, G3I) >*/
gf_(&zp, &g3r, &g3i);
/*< ZP= Z+ DZ >*/
zp = z + dz;
/*< CALL GF( ZP, G5R, G5I) >*/
gf_(&zp, &g5r, &g5i);
/*< 4 T00R=( G1R+ G5R)* DZOT >*/
L4:
t00r = (g1r + g5r) * dzot;
/*< T00I=( G1I+ G5I)* DZOT >*/
t00i = (g1i + g5i) * dzot;
/*< T01R=( T00R+ DZ* G3R)*0.5 >*/
t01r = (t00r + dz * g3r) * .5;
/*< T01I=( T00I+ DZ* G3I)*0.5 >*/
t01i = (t00i + dz * g3i) * .5;
/*< T10R=(4.0* T01R- T00R)/3.0 >*/
t10r = (t01r * 4. - t00r) / 3.;
/* TEST CONVERGENCE OF 3 POINT ROMBERG RESULT. */
/*< T10I=(4.0* T01I- T00I)/3.0 >*/
t10i = (t01i * 4. - t00i) / 3.;
/*< CALL TEST( T01R, T10R, TE1R, T01I, T10I, TE1I,0.) >*/
test_(&t01r, &t10r, &te1r, &t01i, &t10i, &te1i, &c_b594);
/*< IF( TE1I- RX) 5,5,6 >*/
if (te1i - rx <= 0.) {
goto L5;
} else {
goto L6;
}
/*< 5 IF( TE1R- RX) 8,8,6 >*/
L5:
if (te1r - rx <= 0.) {
goto L8;
} else {
goto L6;
}
/*< 6 ZP= Z+ DZ*0.25 >*/
L6:
zp = z + dz * .25;
/*< CALL GF( ZP, G2R, G2I) >*/
gf_(&zp, &g2r, &g2i);
/*< ZP= Z+ DZ*0.75 >*/
zp = z + dz * .75;
/*< CALL GF( ZP, G4R, G4I) >*/
gf_(&zp, &g4r, &g4i);
/*< T02R=( T01R+ DZOT*( G2R+ G4R))*0.5 >*/
t02r = (t01r + dzot * (g2r + g4r)) * .5;
/*< T02I=( T01I+ DZOT*( G2I+ G4I))*0.5 >*/
t02i = (t01i + dzot * (g2i + g4i)) * .5;
/*< T11R=(4.0* T02R- T01R)/3.0 >*/
t11r = (t02r * 4. - t01r) / 3.;
/*< T11I=(4.0* T02I- T01I)/3.0 >*/
t11i = (t02i * 4. - t01i) / 3.;
/*< T20R=(16.0* T11R- T10R)/15.0 >*/
t20r = (t11r * 16. - t10r) / 15.;
/* TEST CONVERGENCE OF 5 POINT ROMBERG RESULT. */
/*< T20I=(16.0* T11I- T10I)/15.0 >*/
t20i = (t11i * 16. - t10i) / 15.;
/*< CALL TEST( T11R, T20R, TE2R, T11I, T20I, TE2I,0.) >*/
test_(&t11r, &t20r, &te2r, &t11i, &t20i, &te2i, &c_b594);
/*< IF( TE2I- RX) 7,7,14 >*/
if (te2i - rx <= 0.) {
goto L7;
} else {
goto L14;
}
/*< 7 IF( TE2R- RX) 9,9,14 >*/
L7:
if (te2r - rx <= 0.) {
goto L9;
} else {
goto L14;
}
/*< 8 SGR= SGR+ T10R >*/
L8:
*sgr += t10r;
/*< SGI= SGI+ T10I >*/
*sgi += t10i;
/*< NT= NT+2 >*/
nt += 2;
/*< GOTO 10 >*/
goto L10;
/*< 9 SGR= SGR+ T20R >*/
L9:
*sgr += t20r;
/*< SGI= SGI+ T20I >*/
*sgi += t20i;
/*< NT= NT+1 >*/
++nt;
/*< 10 Z= Z+ DZ >*/
L10:
z += dz;
/*< IF( Z- ZEND) 11,17,17 >*/
if (z - zend >= 0.) {
goto L17;
} else {
goto L11;
}
/*< 11 G1R= G5R >*/
L11:
g1r = g5r;
/*< G1I= G5I >*/
g1i = g5i;
/*< IF( NT- NTS) 1,12,12 >*/
if (nt - nts >= 0) {
goto L12;
} else {
goto L1;
}
/* DOUBLE STEP SIZE */
/*< 12 IF( NS- NX) 1,1,13 >*/
L12:
if (ns - nx <= 0) {
goto L1;
} else {
goto L13;
}
/*< 13 NS= NS/2 >*/
L13:
ns /= 2;
/*< NT=1 >*/
nt = 1;
/*< GOTO 1 >*/
goto L1;
/*< 14 NT=0 >*/
L14:
nt = 0;
/*< IF( NS- NM) 16,15,15 >*/
if (ns - nm >= 0) {
goto L15;
} else {
goto L16;
}
/*< 15 WRITE( 6,20) Z >*/
L15:
s_wsfe(&io___1400);
do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
e_wsfe();
/* HALVE STEP SIZE */
/*< GOTO 9 >*/
goto L9;
/*< 16 NS= NS*2 >*/
L16:
ns <<= 1;
/*< FNS= NS >*/
fns = (doublereal) ns;
/*< DZ= S/ FNS >*/
dz = s / fns;
/*< DZOT= DZ*0.5 >*/
dzot = dz * .5;
/*< G5R= G3R >*/
g5r = g3r;
/*< G5I= G3I >*/
g5i = g3i;
/*< G3R= G2R >*/
g3r = g2r;
/*< G3I= G2I >*/
g3i = g2i;
/*< GOTO 4 >*/
goto L4;
/*< 17 CONTINUE >*/
L17:
/* ADD CONTRIBUTION OF NEAR SINGULARITY FOR DIAGONAL TERM */
/*< IF( IJ) 19,18,19 >*/
if (*ij != 0) {
goto L19;
} else {
goto L18;
}
/*< 18 SGR=2.*( SGR+ LOG(( SQRT( B* B+ S* S)+ S)/ B)) >*/
L18:
*sgr = (*sgr + log((sqrt(*b * *b + s * s) + s) / *b)) * 2.;
/*< SGI=2.* SGI >*/
*sgi *= 2.;
/*< 19 CONTINUE >*/
L19:
/*< RETURN >*/
return 0;
/*< 20 FORMAT(' STEP SIZE LIMITED AT Z=',F10.5) >*/
/*< END >*/
} /* intx_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< FUNCTION ISEGNO( ITAGI, MX) >*/
integer isegno_(itagi, mx)
integer *itagi, *mx;
{
/* Format strings */
static char fmt_6[] = "(4x,\002CHECK DATA, PARAMETER SPECIFYING SEGMENT \
POSITION IN\002,\002 A GROUP OF EQUAL TAGS MUST NOT BE ZERO\002)";
static char fmt_7[] = "(///,10x,\002NO SEGMENT HAS AN ITAG OF \002,i5)";
/* System generated locals */
integer ret_val, i__1;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
integer do_fio();
/* Local variables */
static integer icnt, i;
/* Fortran I/O blocks */
static cilist io___1401 = { 0, 6, 0, fmt_6, 0 };
static cilist io___1404 = { 0, 6, 0, fmt_7, 0 };
/* *** */
/* ISEGNO RETURNS THE SEGMENT NUMBER OF THE MTH SEGMENT HAVING THE */
/* TAG NUMBER ITAGI. IF ITAGI=0 SEGMENT NUMBER M IS RETURNED. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< IF( MX.GT.0) GOTO 1 >*/
if (*mx > 0) {
goto L1;
}
/*< WRITE( 6,6) >*/
s_wsfe(&io___1401);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 1 ICNT=0 >*/
L1:
icnt = 0;
/*< IF( ITAGI.NE.0) GOTO 2 >*/
if (*itagi != 0) {
goto L2;
}
/*< ISEGNO= MX >*/
ret_val = *mx;
/*< RETURN >*/
return ret_val;
/*< 2 IF( N.LT.1) GOTO 4 >*/
L2:
if (data_1.n < 1) {
goto L4;
}
/*< DO 3 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< IF( ITAG( I).NE. ITAGI) GOTO 3 >*/
if (data_1.itag[i - 1] != *itagi) {
goto L3;
}
/*< ICNT= ICNT+1 >*/
++icnt;
/*< IF( ICNT.EQ. MX) GOTO 5 >*/
if (icnt == *mx) {
goto L5;
}
/*< 3 CONTINUE >*/
L3:
;
}
/*< 4 WRITE( 6,7) ITAGI >*/
L4:
s_wsfe(&io___1404);
do_fio(&c__1, (char *)&(*itagi), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 5 ISEGNO= I >*/
L5:
ret_val = i;
/*< RETURN >*/
return ret_val;
/*< >*/
/*< 7 FORMAT(///,10X,'NO SEGMENT HAS AN ITAG OF ',I5) >*/
/*< END >*/
} /* isegno_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE LFACTR( A, NROW, IX1, IX2, IP) >*/
/* Subroutine */ int lfactr_(a, nrow, ix1, ix2, ip)
doublecomplex *a;
integer *nrow, *ix1, *ix2, *ip;
{
/* Format strings */
static char fmt_17[] = "(\002 \002,\002PIVOT(,I3,2H)=\002,1p,e16.8)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2;
/* Builtin functions */
void d_cnjg(), z_div();
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static integer iflg;
static doublereal dmax_;
static integer i, j, k, r;
static doublereal elmag;
static integer j1, j2;
static logical l1, l2, l3;
static integer r1, r2, pj, pr, jp1;
static doublecomplex ajr;
static integer j2p1, j2p2, ixj;
/* Fortran I/O blocks */
static cilist io___1426 = { 0, 6, 0, fmt_17, 0 };
/* *** */
/* LFACTR PERFORMS GAUSS-DOOLITTLE MANIPULATIONS ON THE TWO BLOCKS OF
*/
/* THE TRANSPOSED MATRIX IN CORE STORAGE. THE GAUSS-DOOLITTLE */
/* ALGORITHM IS PRESENTED ON PAGES 411-416 OF A. RALSTON -- A FIRST */
/* COURSE IN NUMERICAL ANALYSIS. COMMENTS BELOW REFER TO COMMENTS IN
*/
/* RALSTONS TEXT. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, D, AJR >*/
/*< INTEGER R, R1, R2, PJ, PR >*/
/*< LOGICAL L1, L2, L3 >*/
/*< >*/
/*< COMMON /SCRATM/ D( N2M) >*/
/*< DIMENSION A( NROW,1), IP( NROW) >*/
/* INITIALIZE R1,R2,J1,J2 */
/*< IFLG=0 >*/
/* Parameter adjustments */
--ip;
a_dim1 = *nrow;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
iflg = 0;
/*< L1= IX1.EQ.1.AND. IX2.EQ.2 >*/
l1 = *ix1 == 1 && *ix2 == 2;
/*< L2=( IX2-1).EQ. IX1 >*/
l2 = *ix2 - 1 == *ix1;
/*< L3= IX2.EQ. NBLSYM >*/
l3 = *ix2 == matpar_1.nblsym;
/*< IF( L1) GOTO 1 >*/
if (l1) {
goto L1;
}
/*< GOTO 2 >*/
goto L2;
/*< 1 R1=1 >*/
L1:
r1 = 1;
/*< R2=2* NPSYM >*/
r2 = matpar_1.npsym << 1;
/*< J1=1 >*/
j1 = 1;
/*< J2=-1 >*/
j2 = -1;
/*< GOTO 5 >*/
goto L5;
/*< 2 R1= NPSYM+1 >*/
L2:
r1 = matpar_1.npsym + 1;
/*< R2=2* NPSYM >*/
r2 = matpar_1.npsym << 1;
/*< J1=( IX1-1)* NPSYM+1 >*/
j1 = (*ix1 - 1) * matpar_1.npsym + 1;
/*< IF( L2) GOTO 3 >*/
if (l2) {
goto L3;
}
/*< GOTO 4 >*/
goto L4;
/*< 3 J2= J1+ NPSYM-2 >*/
L3:
j2 = j1 + matpar_1.npsym - 2;
/*< GOTO 5 >*/
goto L5;
/*< 4 J2= J1+ NPSYM-1 >*/
L4:
j2 = j1 + matpar_1.npsym - 1;
/*< 5 IF( L3) R2= NPSYM+ NLSYM >*/
L5:
if (l3) {
r2 = matpar_1.npsym + matpar_1.nlsym;
}
/* STEP 1 */
/*< DO 16 R= R1, R2 >*/
i__1 = r2;
for (r = r1; r <= i__1; ++r) {
/*< DO 6 K= J1, NROW >*/
i__2 = *nrow;
for (k = j1; k <= i__2; ++k) {
/*< D( K)= A( K, R) >*/
i__3 = k - 1;
i__4 = k + r * a_dim1;
scratm_1.d[i__3].r = a[i__4].r, scratm_1.d[i__3].i = a[i__4].i;
/* STEPS 2 AND 3 */
/*< 6 CONTINUE >*/
/* L6: */
}
/*< IF( L1.OR. L2) J2= J2+1 >*/
if (l1 || l2) {
++j2;
}
/*< IF( J1.GT. J2) GOTO 9 >*/
if (j1 > j2) {
goto L9;
}
/*< IXJ=0 >*/
ixj = 0;
/*< DO 8 J= J1, J2 >*/
i__2 = j2;
for (j = j1; j <= i__2; ++j) {
/*< IXJ= IXJ+1 >*/
++ixj;
/*< PJ= IP( J) >*/
pj = ip[j];
/*< AJR= D( PJ) >*/
i__3 = pj - 1;
ajr.r = scratm_1.d[i__3].r, ajr.i = scratm_1.d[i__3].i;
/*< A( J, R)= AJR >*/
i__3 = j + r * a_dim1;
a[i__3].r = ajr.r, a[i__3].i = ajr.i;
/*< D( PJ)= D( J) >*/
i__3 = pj - 1;
i__4 = j - 1;
scratm_1.d[i__3].r = scratm_1.d[i__4].r, scratm_1.d[i__3].i =
scratm_1.d[i__4].i;
/*< JP1= J+1 >*/
jp1 = j + 1;
/*< DO 7 I= JP1, NROW >*/
i__3 = *nrow;
for (i = jp1; i <= i__3; ++i) {
/*< D( I)= D( I)- A( I, IXJ)* AJR >*/
i__4 = i - 1;
i__5 = i - 1;
i__6 = i + ixj * a_dim1;
z__2.r = a[i__6].r * ajr.r - a[i__6].i * ajr.i, z__2.i = a[
i__6].r * ajr.i + a[i__6].i * ajr.r;
z__1.r = scratm_1.d[i__5].r - z__2.r, z__1.i = scratm_1.d[
i__5].i - z__2.i;
scratm_1.d[i__4].r = z__1.r, scratm_1.d[i__4].i = z__1.i;
/*< 7 CONTINUE >*/
/* L7: */
}
/*< 8 CONTINUE >*/
/* L8: */
}
/* STEP 4 */
/*< 9 CONTINUE >*/
L9:
/*< J2P1= J2+1 >*/
j2p1 = j2 + 1;
/*< IF( L1.OR. L2) GOTO 11 >*/
if (l1 || l2) {
goto L11;
}
/*< IF( NROW.LT. J2P1) GOTO 16 >*/
if (*nrow < j2p1) {
goto L16;
}
/*< DO 10 I= J2P1, NROW >*/
i__2 = *nrow;
for (i = j2p1; i <= i__2; ++i) {
/*< A( I, R)= D( I) >*/
i__3 = i + r * a_dim1;
i__4 = i - 1;
a[i__3].r = scratm_1.d[i__4].r, a[i__3].i = scratm_1.d[i__4].i;
/*< 10 CONTINUE >*/
/* L10: */
}
/*< GOTO 16 >*/
goto L16;
/*< 11 DMAX= REAL( D( J2P1)* CONJG( D( J2P1))) >*/
L11:
i__2 = j2p1 - 1;
d_cnjg(&z__2, &scratm_1.d[j2p1 - 1]);
z__1.r = scratm_1.d[i__2].r * z__2.r - scratm_1.d[i__2].i * z__2.i,
z__1.i = scratm_1.d[i__2].r * z__2.i + scratm_1.d[i__2].i *
z__2.r;
dmax_ = z__1.r;
/*< IP( J2P1)= J2P1 >*/
ip[j2p1] = j2p1;
/*< J2P2= J2+2 >*/
j2p2 = j2 + 2;
/*< IF( J2P2.GT. NROW) GOTO 13 >*/
if (j2p2 > *nrow) {
goto L13;
}
/*< DO 12 I= J2P2, NROW >*/
i__2 = *nrow;
for (i = j2p2; i <= i__2; ++i) {
/*< ELMAG= REAL( D( I)* CONJG( D( I))) >*/
i__3 = i - 1;
d_cnjg(&z__2, &scratm_1.d[i - 1]);
z__1.r = scratm_1.d[i__3].r * z__2.r - scratm_1.d[i__3].i *
z__2.i, z__1.i = scratm_1.d[i__3].r * z__2.i + scratm_1.d[
i__3].i * z__2.r;
elmag = z__1.r;
/*< IF( ELMAG.LT. DMAX) GOTO 12 >*/
if (elmag < dmax_) {
goto L12;
}
/*< DMAX= ELMAG >*/
dmax_ = elmag;
/*< IP( J2P1)= I >*/
ip[j2p1] = i;
/*< 12 CONTINUE >*/
L12:
;
}
/*< 13 CONTINUE >*/
L13:
/*< IF( DMAX.LT.1.D-10) IFLG=1 >*/
if (dmax_ < 1e-10) {
iflg = 1;
}
/*< PR= IP( J2P1) >*/
pr = ip[j2p1];
/*< A( J2P1, R)= D( PR) >*/
i__2 = j2p1 + r * a_dim1;
i__3 = pr - 1;
a[i__2].r = scratm_1.d[i__3].r, a[i__2].i = scratm_1.d[i__3].i;
/* STEP 5 */
/*< D( PR)= D( J2P1) >*/
i__2 = pr - 1;
i__3 = j2p1 - 1;
scratm_1.d[i__2].r = scratm_1.d[i__3].r, scratm_1.d[i__2].i =
scratm_1.d[i__3].i;
/*< IF( J2P2.GT. NROW) GOTO 15 >*/
if (j2p2 > *nrow) {
goto L15;
}
/*< AJR=1./ A( J2P1, R) >*/
z_div(&z__1, &c_b48, &a[j2p1 + r * a_dim1]);
ajr.r = z__1.r, ajr.i = z__1.i;
/*< DO 14 I= J2P2, NROW >*/
i__2 = *nrow;
for (i = j2p2; i <= i__2; ++i) {
/*< A( I, R)= D( I)* AJR >*/
i__3 = i + r * a_dim1;
i__4 = i - 1;
z__1.r = scratm_1.d[i__4].r * ajr.r - scratm_1.d[i__4].i * ajr.i,
z__1.i = scratm_1.d[i__4].r * ajr.i + scratm_1.d[i__4].i *
ajr.r;
a[i__3].r = z__1.r, a[i__3].i = z__1.i;
/*< 14 CONTINUE >*/
/* L14: */
}
/*< 15 CONTINUE >*/
L15:
/*< IF( IFLG.EQ.0) GOTO 16 >*/
if (iflg == 0) {
goto L16;
}
/*< WRITE( 6,17) J2, DMAX >*/
s_wsfe(&io___1426);
do_fio(&c__1, (char *)&j2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&dmax_, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IFLG=0 >*/
iflg = 0;
/*< 16 CONTINUE >*/
L16:
;
}
/*< RETURN >*/
return 0;
/*< 17 FORMAT(' ','PIVOT(,I3,2H)=',1P,E16.8) >*/
/*< END >*/
} /* lfactr_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE LOAD( LDTYP, LDTAG, LDTAGF, LDTAGT, ZLR, ZLI, ZLC) >*/
/* Subroutine */ int load_(ldtyp, ldtag, ldtagf, ldtagt, zlr, zli, zlc)
integer *ldtyp, *ldtag, *ldtagf, *ldtagt;
doublereal *zlr, *zli, *zlc;
{
/* Initialized data */
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 1883698955., 0. };
/* Format strings */
static char fmt_25[] = "(//,7x,\002LOCATION\002,10x,\002RESISTANCE\002,3\
x,\002INDUCTANCE\002,2x,\002CAPACITANCE\002,7x,\002IMPEDANCE (OHMS)\002,5x\
,\002CONDUCTIVITY\002,4x,\002TYPE\002,/,4x,\002ITAG\002,\002 FROM THRU\002,1\
0x,\002OHMS\002,8x,\002HENRYS\002,7x,\002FARADS\002,8x,\002REAL\002,6x,\002I\
MAGINARY\002,4x,\002MHOS/METER\002)";
static char fmt_26[] = "(/,10x,\002NOTE, SOME OF THE ABOVE SEGMENTS HAVE\
BEEN LOADED\002,\002 TWICE - IMPEDANCES ADDED\002)";
static char fmt_27[] = "(/,10x,\002IMPROPER LOAD TYPE CHOOSEN, REQUESTED\
TYPE IS \002,i3)";
static char fmt_29[] = "(\002 ERROR - LOADING MAY NOT BE ADDED TO SEGMEN\
TS IN N.G.F.\002\002 SECTION\002)";
static char fmt_28[] = "(/,10x,\002LOADING DATA CARD ERROR, NO SEGMENT H\
AS AN ITAG =\002,i5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
integer s_wsfe(), e_wsfe(), do_fio();
/* Subroutine */ int s_stop();
void z_div();
double d_imag();
/* Local variables */
static integer ichk;
#define tpcj ((doublecomplex *)&equiv_0)
static integer jump;
extern /* Subroutine */ int prnt_();
extern /* Double Complex */ int zint_();
static integer i, iwarn, istep;
#define tpcjx ((doublereal *)&equiv_0)
static integer l1, l2;
static doublecomplex zt;
static integer ldtags, nop;
/* Fortran I/O blocks */
static cilist io___1429 = { 0, 6, 0, fmt_25, 0 };
static cilist io___1433 = { 0, 6, 0, fmt_26, 0 };
static cilist io___1438 = { 0, 6, 0, fmt_27, 0 };
static cilist io___1442 = { 0, 6, 0, fmt_29, 0 };
static cilist io___1443 = { 0, 6, 0, fmt_28, 0 };
/* *** */
/* LOAD CALCULATES THE IMPEDANCE OF SPECIFIED SEGMENTS FOR VARIOUS */
/* TYPES OF LOADING */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX ZARRAY, ZT, TPCJ, ZINT >*/
/*< >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< >*/
/*< EQUIVALENCE(TPCJ,TPCJX) >*/
/* WRITE(6,HEADING) */
/*< DATA TPCJX/0.,1.883698955D+9/ >*/
/* Parameter adjustments */
--zlc;
--zli;
--zlr;
--ldtagt;
--ldtagf;
--ldtag;
--ldtyp;
/* Function Body */
/* INITIALIZE D ARRAY, USED FOR TEMPORARY STORAGE OF LOADING */
/* INFORMATION. */
/*< WRITE( 6,25) >*/
s_wsfe(&io___1429);
e_wsfe();
/*< DO 1 I= N2, N >*/
i__1 = data_1.n;
for (i = data_1.n2; i <= i__1; ++i) {
/*< 1 ZARRAY( I)=(0.,0.) >*/
/* L1: */
i__2 = i - 1;
zload_1.zarray[i__2].r = 0., zload_1.zarray[i__2].i = 0.;
}
/* CYCLE OVER LOADING CARDS */
/*< IWARN=0 >*/
iwarn = 0;
/*< ISTEP=0 >*/
istep = 0;
/*< 2 ISTEP= ISTEP+1 >*/
L2:
++istep;
/*< IF( ISTEP.LE. NLOAD) GOTO 5 >*/
if (istep <= zload_1.nload) {
goto L5;
}
/*< IF( IWARN.EQ.1) WRITE( 6,26) >*/
if (iwarn == 1) {
s_wsfe(&io___1433);
e_wsfe();
}
/*< IF( N1+2* M1.GT.0) GOTO 4 >*/
if (data_1.n1 + (data_1.m1 << 1) > 0) {
goto L4;
}
/*< NOP= N/ NP >*/
nop = data_1.n / data_1.np;
/*< IF( NOP.EQ.1) GOTO 4 >*/
if (nop == 1) {
goto L4;
}
/*< DO 3 I=1, NP >*/
i__2 = data_1.np;
for (i = 1; i <= i__2; ++i) {
/*< ZT= ZARRAY( I) >*/
i__1 = i - 1;
zt.r = zload_1.zarray[i__1].r, zt.i = zload_1.zarray[i__1].i;
/*< L1= I >*/
l1 = i;
/*< DO 3 L2=2, NOP >*/
i__1 = nop;
for (l2 = 2; l2 <= i__1; ++l2) {
/*< L1= L1+ NP >*/
l1 += data_1.np;
/*< 3 ZARRAY( L1)= ZT >*/
/* L3: */
i__3 = l1 - 1;
zload_1.zarray[i__3].r = zt.r, zload_1.zarray[i__3].i = zt.i;
}
}
/*< 4 RETURN >*/
L4:
return 0;
/*< 5 IF( LDTYP( ISTEP).LE.5) GOTO 6 >*/
L5:
if (ldtyp[istep] <= 5) {
goto L6;
}
/*< WRITE( 6,27) LDTYP( ISTEP) >*/
s_wsfe(&io___1438);
do_fio(&c__1, (char *)&ldtyp[istep], (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 6 LDTAGS= LDTAG( ISTEP) >*/
L6:
ldtags = ldtag[istep];
/*< JUMP= LDTYP( ISTEP)+1 >*/
jump = ldtyp[istep] + 1;
/* SEARCH SEGMENTS FOR PROPER ITAGS */
/*< ICHK=0 >*/
ichk = 0;
/*< L1= N2 >*/
l1 = data_1.n2;
/*< L2= N >*/
l2 = data_1.n;
/*< IF( LDTAGS.NE.0) GOTO 7 >*/
if (ldtags != 0) {
goto L7;
}
/*< IF( LDTAGF( ISTEP).EQ.0.AND. LDTAGT( ISTEP).EQ.0) GOTO 7 >*/
if (ldtagf[istep] == 0 && ldtagt[istep] == 0) {
goto L7;
}
/*< L1= LDTAGF( ISTEP) >*/
l1 = ldtagf[istep];
/*< L2= LDTAGT( ISTEP) >*/
l2 = ldtagt[istep];
/*< IF( L1.GT. N1) GOTO 7 >*/
if (l1 > data_1.n1) {
goto L7;
}
/*< WRITE( 6,29) >*/
s_wsfe(&io___1442);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 7 DO 17 I= L1, L2 >*/
L7:
i__3 = l2;
for (i = l1; i <= i__3; ++i) {
/*< IF( LDTAGS.EQ.0) GOTO 8 >*/
if (ldtags == 0) {
goto L8;
}
/*< IF( LDTAGS.NE. ITAG( I)) GOTO 17 >*/
if (ldtags != data_1.itag[i - 1]) {
goto L17;
}
/*< IF( LDTAGF( ISTEP).EQ.0) GOTO 8 >*/
if (ldtagf[istep] == 0) {
goto L8;
}
/*< ICHK= ICHK+1 >*/
++ichk;
/*< IF( ICHK.GE. LDTAGF( ISTEP).AND. ICHK.LE. LDTAGT( ISTEP)) GOTO 9 >*/
if (ichk >= ldtagf[istep] && ichk <= ldtagt[istep]) {
goto L9;
}
/*< GOTO 17 >*/
goto L17;
/* CALCULATION OF LAMDA*IMPED. PER UNIT LENGTH, JUMP TO APPROPRIAT
E */
/* SECTION FOR LOADING TYPE */
/*< 8 ICHK=1 >*/
L8:
ichk = 1;
/*< 9 GOTO (10,11,12,13,14,15), JUMP >*/
L9:
switch ((int)jump) {
case 1: goto L10;
case 2: goto L11;
case 3: goto L12;
case 4: goto L13;
case 5: goto L14;
case 6: goto L15;
}
/*< 10 ZT= ZLR( ISTEP)/ SI( I)+ TPCJ* ZLI( ISTEP)/( SI( I)* WLAM) >*/
L10:
d__1 = zlr[istep] / data_1.si[i - 1];
i__1 = istep;
z__3.r = zli[i__1] * tpcj->r, z__3.i = zli[i__1] * tpcj->i;
d__2 = data_1.si[i - 1] * data_1.wlam;
z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
/*< >*/
if ((d__1 = zlc[istep], abs(d__1)) > 1e-20) {
z__3.r = data_1.wlam, z__3.i = 0.;
i__1 = i - 1;
z__5.r = data_1.si[i__1] * tpcj->r, z__5.i = data_1.si[i__1] *
tpcj->i;
i__2 = istep;
z__4.r = zlc[i__2] * z__5.r, z__4.i = zlc[i__2] * z__5.i;
z_div(&z__2, &z__3, &z__4);
z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< GOTO 16 >*/
goto L16;
/*< 11 ZT= TPCJ* SI( I)* ZLC( ISTEP)/ WLAM >*/
L11:
i__1 = i - 1;
z__3.r = data_1.si[i__1] * tpcj->r, z__3.i = data_1.si[i__1] *
tpcj->i;
i__2 = istep;
z__2.r = zlc[i__2] * z__3.r, z__2.i = zlc[i__2] * z__3.i;
z__1.r = z__2.r / data_1.wlam, z__1.i = z__2.i / data_1.wlam;
zt.r = z__1.r, zt.i = z__1.i;
/*< >*/
if ((d__1 = zli[istep], abs(d__1)) > 1e-20) {
d__2 = data_1.si[i - 1] * data_1.wlam;
z__3.r = d__2, z__3.i = 0.;
i__1 = istep;
z__4.r = zli[i__1] * tpcj->r, z__4.i = zli[i__1] * tpcj->i;
z_div(&z__2, &z__3, &z__4);
z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+ SI( I)/ ZLR( ISTEP) >*/
if ((d__1 = zlr[istep], abs(d__1)) > 1e-20) {
d__2 = data_1.si[i - 1] / zlr[istep];
z__1.r = zt.r + d__2, z__1.i = zt.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< ZT=1./ ZT >*/
z_div(&z__1, &c_b48, &zt);
zt.r = z__1.r, zt.i = z__1.i;
/*< GOTO 16 >*/
goto L16;
/*< 12 ZT= ZLR( ISTEP)* WLAM+ TPCJ* ZLI( ISTEP) >*/
L12:
d__1 = zlr[istep] * data_1.wlam;
i__1 = istep;
z__2.r = zli[i__1] * tpcj->r, z__2.i = zli[i__1] * tpcj->i;
z__1.r = d__1 + z__2.r, z__1.i = z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
/*< >*/
if ((d__1 = zlc[istep], abs(d__1)) > 1e-20) {
i__1 = i - 1;
z__5.r = data_1.si[i__1] * tpcj->r, z__5.i = data_1.si[i__1] *
tpcj->i;
i__2 = i - 1;
z__4.r = data_1.si[i__2] * z__5.r, z__4.i = data_1.si[i__2] *
z__5.i;
i__4 = istep;
z__3.r = zlc[i__4] * z__4.r, z__3.i = zlc[i__4] * z__4.i;
z_div(&z__2, &c_b48, &z__3);
z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< GOTO 16 >*/
goto L16;
/*< 13 ZT= TPCJ* SI( I)* SI( I)* ZLC( ISTEP) >*/
L13:
i__1 = i - 1;
z__3.r = data_1.si[i__1] * tpcj->r, z__3.i = data_1.si[i__1] *
tpcj->i;
i__2 = i - 1;
z__2.r = data_1.si[i__2] * z__3.r, z__2.i = data_1.si[i__2] * z__3.i;
i__4 = istep;
z__1.r = zlc[i__4] * z__2.r, z__1.i = zlc[i__4] * z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
/*< IF( ABS( ZLI( ISTEP)).GT.1.D-20) ZT= ZT+1./( TPCJ* ZLI( ISTEP)) >*/
if ((d__1 = zli[istep], abs(d__1)) > 1e-20) {
i__1 = istep;
z__3.r = zli[i__1] * tpcj->r, z__3.i = zli[i__1] * tpcj->i;
z_div(&z__2, &c_b48, &z__3);
z__1.r = zt.r + z__2.r, z__1.i = zt.i + z__2.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< IF( ABS( ZLR( ISTEP)).GT.1.D-20) ZT= ZT+1./( ZLR( ISTEP)* WLAM) >*/
if ((d__1 = zlr[istep], abs(d__1)) > 1e-20) {
d__2 = 1. / (zlr[istep] * data_1.wlam);
z__1.r = zt.r + d__2, z__1.i = zt.i;
zt.r = z__1.r, zt.i = z__1.i;
}
/*< ZT=1./ ZT >*/
z_div(&z__1, &c_b48, &zt);
zt.r = z__1.r, zt.i = z__1.i;
/*< GOTO 16 >*/
goto L16;
/*< 14 ZT= CMPLX( ZLR( ISTEP), ZLI( ISTEP))/ SI( I) >*/
L14:
i__1 = istep;
i__2 = istep;
z__2.r = zlr[i__1], z__2.i = zli[i__2];
i__4 = i - 1;
z__1.r = z__2.r / data_1.si[i__4], z__1.i = z__2.i / data_1.si[i__4];
zt.r = z__1.r, zt.i = z__1.i;
/*< GOTO 16 >*/
goto L16;
/*< 15 ZT= ZINT( ZLR( ISTEP)* WLAM, BI( I)) >*/
L15:
d__1 = zlr[istep] * data_1.wlam;
zint_(&z__1, &d__1, &data_1.bi[i - 1]);
zt.r = z__1.r, zt.i = z__1.i;
/*< >*/
L16:
i__1 = i - 1;
if ((d__1 = zload_1.zarray[i__1].r, abs(d__1)) + (d__2 = d_imag(&
zload_1.zarray[i - 1]), abs(d__2)) > 1e-20) {
iwarn = 1;
}
/*< ZARRAY( I)= ZARRAY( I)+ ZT >*/
i__1 = i - 1;
i__2 = i - 1;
z__1.r = zload_1.zarray[i__2].r + zt.r, z__1.i = zload_1.zarray[i__2]
.i + zt.i;
zload_1.zarray[i__1].r = z__1.r, zload_1.zarray[i__1].i = z__1.i;
/*< 17 CONTINUE >*/
L17:
;
}
/*< IF( ICHK.NE.0) GOTO 18 >*/
if (ichk != 0) {
goto L18;
}
/*< WRITE( 6,28) LDTAGS >*/
s_wsfe(&io___1443);
do_fio(&c__1, (char *)&ldtags, (ftnlen)sizeof(integer));
e_wsfe();
/* PRINTING THE SEGMENT LOADING DATA, JUMP TO PROPER PRINT */
/*< STOP >*/
s_stop("", 0L);
/*< 18 GOTO (19,20,21,22,23,24), JUMP >*/
L18:
switch ((int)jump) {
case 1: goto L19;
case 2: goto L20;
case 3: goto L21;
case 4: goto L22;
case 5: goto L23;
case 6: goto L24;
}
/*< >*/
L19:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
zlc[istep], &c_b594, &c_b594, &c_b594, " SERIES ", &c__2, 8L);
/*< GOTO 2 >*/
goto L2;
/*< >*/
L20:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
zlc[istep], &c_b594, &c_b594, &c_b594, "PARALLEL", &c__2, 8L);
/*< GOTO 2 >*/
goto L2;
/*< >*/
L21:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
zlc[istep], &c_b594, &c_b594, &c_b594, "SERIES (PER METER),5",
20L);
/*< GOTO 2 >*/
goto L2;
/*< >*/
L22:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &zlr[istep], &zli[istep], &
zlc[istep], &c_b594, &c_b594, &c_b594, "PARALLEL (PER METER)", &
c__5, 20L);
/*< GOTO 2 >*/
goto L2;
/*< >*/
L23:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &c_b594, &c_b594, &c_b594,
&zlr[istep], &zli[istep], &c_b594, "FIXED IMPEDANCE ", &c__4, 16L)
;
/*< GOTO 2 >*/
goto L2;
/*< >*/
L24:
prnt_(&ldtags, &ldtagf[istep], &ldtagt[istep], &c_b594, &c_b594, &c_b594,
&c_b594, &c_b594, &zlr[istep], " WIRE ", &c__2, 8L);
/*< GOTO 2 >*/
goto L2;
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< END >*/
} /* load_ */
#undef tpcjx
#undef tpcj
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE LTSOLV( A, NROW, IX, B, NEQ, NRH, IFL1, IFL2) >*/
/* Subroutine */ int ltsolv_(a, nrow, ix, b, neq, nrh, ifl1, ifl2)
doublecomplex *a;
integer *nrow, *ix;
doublecomplex *b;
integer *neq, *nrh, *ifl1, *ifl2;
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5,
i__6;
doublecomplex z__1, z__2;
/* Builtin functions */
void z_div();
/* Local variables */
static integer i, j, k, i2, k2, ixblk1, ic, kp;
extern /* Subroutine */ int blckin_();
static integer jm1, jp1, ixi, jst;
static doublecomplex sum;
/* *** */
/* LTSOLV SOLVES THE MATRIX EQ. Y(R)*LU(T)=B(R) WHERE (R) DENOTES ROW
*/
/* VECTOR AND LU(T) DENOTES THE LU DECOMPOSITION OF THE TRANSPOSE OF
*/
/* THE ORIGINAL COEFFICIENT MATRIX. THE LU(T) DECOMPOSITION IS */
/* STORED ON TAPE 5 IN BLOCKS IN ASCENDING ORDER AND ON FILE 3 IN */
/* BLOCKS OF DESCENDING ORDER. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, B, Y, SUM >*/
/*< >*/
/*< COMMON /SCRATM/ Y( N2M) >*/
/* FORWARD SUBSTITUTION */
/*< DIMENSION A( NROW, NROW), B( NEQ, NRH), IX( NEQ) >*/
/*< I2=2* NPSYM* NROW >*/
/* Parameter adjustments */
b_dim1 = *neq;
b_offset = b_dim1 + 1;
b -= b_offset;
--ix;
a_dim1 = *nrow;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
i2 = (matpar_1.npsym << 1) * *nrow;
/*< DO 4 IXBLK1=1, NBLSYM >*/
i__1 = matpar_1.nblsym;
for (ixblk1 = 1; ixblk1 <= i__1; ++ixblk1) {
/*< CALL BLCKIN( A, IFL1,1, I2,1,121) >*/
blckin_(&a[a_offset], ifl1, &c__1, &i2, &c__1, &c__121);
/*< K2= NPSYM >*/
k2 = matpar_1.npsym;
/*< IF( IXBLK1.EQ. NBLSYM) K2= NLSYM >*/
if (ixblk1 == matpar_1.nblsym) {
k2 = matpar_1.nlsym;
}
/*< JST=( IXBLK1-1)* NPSYM >*/
jst = (ixblk1 - 1) * matpar_1.npsym;
/*< DO 4 IC=1, NRH >*/
i__2 = *nrh;
for (ic = 1; ic <= i__2; ++ic) {
/*< J= JST >*/
j = jst;
/*< DO 3 K=1, K2 >*/
i__3 = k2;
for (k = 1; k <= i__3; ++k) {
/*< JM1= J >*/
jm1 = j;
/*< J= J+1 >*/
++j;
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< IF( JM1.LT.1) GOTO 2 >*/
if (jm1 < 1) {
goto L2;
}
/*< DO 1 I=1, JM1 >*/
i__4 = jm1;
for (i = 1; i <= i__4; ++i) {
/*< 1 SUM= SUM+ A( I, K)* B( I, IC) >*/
/* L1: */
i__5 = i + k * a_dim1;
i__6 = i + ic * b_dim1;
z__2.r = a[i__5].r * b[i__6].r - a[i__5].i * b[i__6].i,
z__2.i = a[i__5].r * b[i__6].i + a[i__5].i * b[
i__6].r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< 2 B( J, IC)=( B( J, IC)- SUM)/ A( J, K) >*/
L2:
i__5 = j + ic * b_dim1;
i__6 = j + ic * b_dim1;
z__2.r = b[i__6].r - sum.r, z__2.i = b[i__6].i - sum.i;
z_div(&z__1, &z__2, &a[j + k * a_dim1]);
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
/*< 3 CONTINUE >*/
/* L3: */
}
/* BACKWARD SUBSTITUTION */
/*< 4 CONTINUE >*/
/* L4: */
}
}
/*< JST= NROW+1 >*/
jst = *nrow + 1;
/*< DO 8 IXBLK1=1, NBLSYM >*/
i__2 = matpar_1.nblsym;
for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
/*< CALL BLCKIN( A, IFL2,1, I2,1,122) >*/
blckin_(&a[a_offset], ifl2, &c__1, &i2, &c__1, &c__122);
/*< K2= NPSYM >*/
k2 = matpar_1.npsym;
/*< IF( IXBLK1.EQ.1) K2= NLSYM >*/
if (ixblk1 == 1) {
k2 = matpar_1.nlsym;
}
/*< DO 7 IC=1, NRH >*/
i__1 = *nrh;
for (ic = 1; ic <= i__1; ++ic) {
/*< KP= K2+1 >*/
kp = k2 + 1;
/*< J= JST >*/
j = jst;
/*< DO 6 K=1, K2 >*/
i__3 = k2;
for (k = 1; k <= i__3; ++k) {
/*< KP= KP-1 >*/
--kp;
/*< JP1= J >*/
jp1 = j;
/*< J= J-1 >*/
--j;
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< IF( NROW.LT. JP1) GOTO 6 >*/
if (*nrow < jp1) {
goto L6;
}
/*< DO 5 I= JP1, NROW >*/
i__5 = *nrow;
for (i = jp1; i <= i__5; ++i) {
/*< 5 SUM= SUM+ A( I, KP)* B( I, IC) >*/
/* L5: */
i__6 = i + kp * a_dim1;
i__4 = i + ic * b_dim1;
z__2.r = a[i__6].r * b[i__4].r - a[i__6].i * b[i__4].i,
z__2.i = a[i__6].r * b[i__4].i + a[i__6].i * b[
i__4].r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< B( J, IC)= B( J, IC)- SUM >*/
i__6 = j + ic * b_dim1;
i__4 = j + ic * b_dim1;
z__1.r = b[i__4].r - sum.r, z__1.i = b[i__4].i - sum.i;
b[i__6].r = z__1.r, b[i__6].i = z__1.i;
/*< 6 CONTINUE >*/
L6:
;
}
/*< 7 CONTINUE >*/
/* L7: */
}
/* UNSCRAMBLE SOLUTION */
/*< 8 JST= JST- K2 >*/
/* L8: */
jst -= k2;
}
/*< DO 10 IC=1, NRH >*/
i__2 = *nrh;
for (ic = 1; ic <= i__2; ++ic) {
/*< DO 9 I=1, NROW >*/
i__1 = *nrow;
for (i = 1; i <= i__1; ++i) {
/*< IXI= IX( I) >*/
ixi = ix[i];
/*< 9 Y( IXI)= B( I, IC) >*/
/* L9: */
i__3 = ixi - 1;
i__6 = i + ic * b_dim1;
scratm_2.y[i__3].r = b[i__6].r, scratm_2.y[i__3].i = b[i__6].i;
}
/*< DO 10 I=1, NROW >*/
i__3 = *nrow;
for (i = 1; i <= i__3; ++i) {
/*< 10 B( I, IC)= Y( I) >*/
/* L10: */
i__6 = i + ic * b_dim1;
i__1 = i - 1;
b[i__6].r = scratm_2.y[i__1].r, b[i__6].i = scratm_2.y[i__1].i;
}
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* ltsolv_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE LUNSCR( A, NROW, NOP, IX, IP, IU2, IU3, IU4) >*/
/* Subroutine */ int lunscr_(a, nrow, nop, ix, ip, iu2, iu3, iu4)
doublecomplex *a;
integer *nrow, *nop, *ix, *ip, *iu2, *iu3, *iu4;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
alist al__1, al__2;
/* Builtin functions */
integer f_rew(), f_back();
/* Local variables */
static doublecomplex temp;
static integer i, j, k, i1, i2, k1, j2, ixblk1, ka, kk;
extern /* Subroutine */ int blckin_(), blckot_();
static integer nb1, nm1, ipi, ipk, ixt;
/* *** */
/* S/R WHICH UNSCRAMBLES, SCRAMBLED FACTORED MATRIX */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, TEMP >*/
/*< >*/
/*< DIMENSION A( NROW,1), IP( NROW), IX( NROW) >*/
/*< I1=1 >*/
/* Parameter adjustments */
--ip;
--ix;
a_dim1 = *nrow;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
i1 = 1;
/*< I2=2* NPSYM* NROW >*/
i2 = (matpar_1.npsym << 1) * *nrow;
/*< NM1= NROW-1 >*/
nm1 = *nrow - 1;
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< REWIND IU4 >*/
al__1.aerr = 0;
al__1.aunit = *iu4;
f_rew(&al__1);
/*< DO 9 KK=1, NOP >*/
i__1 = *nop;
for (kk = 1; kk <= i__1; ++kk) {
/*< KA=( KK-1)* NROW >*/
ka = (kk - 1) * *nrow;
/*< DO 4 IXBLK1=1, NBLSYM >*/
i__2 = matpar_1.nblsym;
for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
/*< CALL BLCKIN( A, IU2, I1, I2,1,121) >*/
blckin_(&a[a_offset], iu2, &i1, &i2, &c__1, &c__121);
/*< K1=( IXBLK1-1)* NPSYM+2 >*/
k1 = (ixblk1 - 1) * matpar_1.npsym + 2;
/*< IF( NM1.LT. K1) GOTO 3 >*/
if (nm1 < k1) {
goto L3;
}
/*< J2=0 >*/
j2 = 0;
/*< DO 2 K= K1, NM1 >*/
i__3 = nm1;
for (k = k1; k <= i__3; ++k) {
/*< IF( J2.LT. NPSYM) J2= J2+1 >*/
if (j2 < matpar_1.npsym) {
++j2;
}
/*< IPK= IP( K+ KA) >*/
ipk = ip[k + ka];
/*< DO 1 J=1, J2 >*/
i__4 = j2;
for (j = 1; j <= i__4; ++j) {
/*< TEMP= A( K, J) >*/
i__5 = k + j * a_dim1;
temp.r = a[i__5].r, temp.i = a[i__5].i;
/*< A( K, J)= A( IPK, J) >*/
i__5 = k + j * a_dim1;
i__6 = ipk + j * a_dim1;
a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i;
/*< A( IPK, J)= TEMP >*/
i__5 = ipk + j * a_dim1;
a[i__5].r = temp.r, a[i__5].i = temp.i;
/*< 1 CONTINUE >*/
/* L1: */
}
/*< 2 CONTINUE >*/
/* L2: */
}
/*< 3 CONTINUE >*/
L3:
/*< CALL BLCKOT( A, IU3, I1, I2,1,122) >*/
blckot_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__122);
/*< 4 CONTINUE >*/
/* L4: */
}
/*< DO 5 IXBLK1=1, NBLSYM >*/
i__2 = matpar_1.nblsym;
for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
/*< BACKSPACE IU3 >*/
al__2.aerr = 0;
al__2.aunit = *iu3;
f_back(&al__2);
/*< IF( IXBLK1.NE.1) BACKSPACE IU3 >*/
if (ixblk1 != 1) {
al__2.aerr = 0;
al__2.aunit = *iu3;
f_back(&al__2);
}
/*< CALL BLCKIN( A, IU3, I1, I2,1,123) >*/
blckin_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__123);
/*< CALL BLCKOT( A, IU4, I1, I2,1,124) >*/
blckot_(&a[a_offset], iu4, &i1, &i2, &c__1, &c__124);
/*< 5 CONTINUE >*/
/* L5: */
}
/*< DO 6 I=1, NROW >*/
i__2 = *nrow;
for (i = 1; i <= i__2; ++i) {
/*< IX( I+ KA)= I >*/
ix[i + ka] = i;
/*< 6 CONTINUE >*/
/* L6: */
}
/*< DO 7 I=1, NROW >*/
i__2 = *nrow;
for (i = 1; i <= i__2; ++i) {
/*< IPI= IP( I+ KA) >*/
ipi = ip[i + ka];
/*< IXT= IX( I+ KA) >*/
ixt = ix[i + ka];
/*< IX( I+ KA)= IX( IPI+ KA) >*/
ix[i + ka] = ix[ipi + ka];
/*< IX( IPI+ KA)= IXT >*/
ix[ipi + ka] = ixt;
/*< 7 CONTINUE >*/
/* L7: */
}
/*< IF( NOP.EQ.1) GOTO 9 >*/
if (*nop == 1) {
goto L9;
}
/* SKIP NB1 LOGICAL RECORDS FORWARD */
/*< NB1= NBLSYM-1 >*/
nb1 = matpar_1.nblsym - 1;
/*< DO 8 IXBLK1=1, NB1 >*/
i__2 = nb1;
for (ixblk1 = 1; ixblk1 <= i__2; ++ixblk1) {
/*< CALL BLCKIN( A, IU3, I1, I2,1,125) >*/
blckin_(&a[a_offset], iu3, &i1, &i2, &c__1, &c__125);
/*< 8 CONTINUE >*/
/* L8: */
}
/*< 9 CONTINUE >*/
L9:
;
}
/*< REWIND IU2 >*/
al__1.aerr = 0;
al__1.aunit = *iu2;
f_rew(&al__1);
/*< REWIND IU3 >*/
al__1.aerr = 0;
al__1.aunit = *iu3;
f_rew(&al__1);
/*< REWIND IU4 >*/
al__1.aerr = 0;
al__1.aunit = *iu4;
f_rew(&al__1);
/*< RETURN >*/
return 0;
/*< END >*/
} /* lunscr_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE MOVE( ROX, ROY, ROZ, XS, YS, ZS, ITS, NRPT, ITGI) >*/
/* Subroutine */ int move_(rox, roy, roz, xs, ys, zs, its, nrpt, itgi)
doublereal *rox, *roy, *roz, *xs, *ys, *zs;
integer *its, *nrpt, *itgi;
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sin(), cos();
/* Local variables */
static integer i, k, i1;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static integer ii, ir, kr, ix;
static doublereal xi, yi, zi, xx, xy, xz, yx, yy, yz, zx, zy, zz;
extern integer isegno_();
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
static integer ldi;
static doublereal cph, cth, cps, sph, sth;
static integer nrp;
static doublereal sps;
/* *** */
/* SUBROUTINE MOVE MOVES THE STRUCTURE WITH RESPECT TO ITS */
/* COORDINATE SYSTEM OR REPRODUCES STRUCTURE IN NEW POSITIONS. */
/* STRUCTURE IS ROTATED ABOUT X,Y,Z AXES BY ROX,ROY,ROZ */
/* RESPECTIVELY, THEN SHIFTED BY XS,YS,ZS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
/*< >*/
/*< IF( ABS( ROX)+ ABS( ROY).GT.1.D-10) IPSYM= IPSYM*3 >*/
if (abs(*rox) + abs(*roy) > 1e-10) {
data_1.ipsym *= 3;
}
/*< SPS= SIN( ROX) >*/
sps = sin(*rox);
/*< CPS= COS( ROX) >*/
cps = cos(*rox);
/*< STH= SIN( ROY) >*/
sth = sin(*roy);
/*< CTH= COS( ROY) >*/
cth = cos(*roy);
/*< SPH= SIN( ROZ) >*/
sph = sin(*roz);
/*< CPH= COS( ROZ) >*/
cph = cos(*roz);
/*< XX= CPH* CTH >*/
xx = cph * cth;
/*< XY= CPH* STH* SPS- SPH* CPS >*/
d__1 = cph * sth;
xy = d__1 * sps - sph * cps;
/*< XZ= CPH* STH* CPS+ SPH* SPS >*/
d__1 = cph * sth;
xz = d__1 * cps + sph * sps;
/*< YX= SPH* CTH >*/
yx = sph * cth;
/*< YY= SPH* STH* SPS+ CPH* CPS >*/
d__1 = sph * sth;
yy = d__1 * sps + cph * cps;
/*< YZ= SPH* STH* CPS- CPH* SPS >*/
d__1 = sph * sth;
yz = d__1 * cps - cph * sps;
/*< ZX=- STH >*/
zx = -sth;
/*< ZY= CTH* SPS >*/
zy = cth * sps;
/*< ZZ= CTH* CPS >*/
zz = cth * cps;
/*< NRP= NRPT >*/
nrp = *nrpt;
/*< IF( NRPT.EQ.0) NRP=1 >*/
if (*nrpt == 0) {
nrp = 1;
}
/*< IX=1 >*/
ix = 1;
/*< IF( N.LT. N2) GOTO 3 >*/
if (data_1.n < data_1.n2) {
goto L3;
}
/*< I1= ISEGNO( ITS,1) >*/
i1 = isegno_(its, &c__1);
/*< IF( I1.LT. N2) I1= N2 >*/
if (i1 < data_1.n2) {
i1 = data_1.n2;
}
/*< IX= I1 >*/
ix = i1;
/*< K= N >*/
k = data_1.n;
/*< IF( NRPT.EQ.0) K= I1-1 >*/
if (*nrpt == 0) {
k = i1 - 1;
}
/*< DO 2 IR=1, NRP >*/
i__1 = nrp;
for (ir = 1; ir <= i__1; ++ir) {
/*< DO 1 I= I1, N >*/
i__2 = data_1.n;
for (i = i1; i <= i__2; ++i) {
/*< K= K+1 >*/
++k;
/*< XI= X( I) >*/
xi = data_1.x[i - 1];
/*< YI= Y( I) >*/
yi = data_1.y[i - 1];
/*< ZI= Z( I) >*/
zi = data_1.z[i - 1];
/*< X( K)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
d__2 = xi * xx + yi * xy;
d__1 = d__2 + zi * xz;
data_1.x[k - 1] = d__1 + *xs;
/*< Y( K)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
d__2 = xi * yx + yi * yy;
d__1 = d__2 + zi * yz;
data_1.y[k - 1] = d__1 + *ys;
/*< Z( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
d__2 = xi * zx + yi * zy;
d__1 = d__2 + zi * zz;
data_1.z[k - 1] = d__1 + *zs;
/*< XI= X2( I) >*/
xi = x2[i - 1];
/*< YI= Y2( I) >*/
yi = y2[i - 1];
/*< ZI= Z2( I) >*/
zi = z2[i - 1];
/*< X2( K)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
d__2 = xi * xx + yi * xy;
d__1 = d__2 + zi * xz;
x2[k - 1] = d__1 + *xs;
/*< Y2( K)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
d__2 = xi * yx + yi * yy;
d__1 = d__2 + zi * yz;
y2[k - 1] = d__1 + *ys;
/*< Z2( K)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
d__2 = xi * zx + yi * zy;
d__1 = d__2 + zi * zz;
z2[k - 1] = d__1 + *zs;
/*< BI( K)= BI( I) >*/
data_1.bi[k - 1] = data_1.bi[i - 1];
/*< ITAG( K)= ITAG( I) >*/
data_1.itag[k - 1] = data_1.itag[i - 1];
/*< IF( ITAG( I).NE.0) ITAG( K)= ITAG( I)+ ITGI >*/
if (data_1.itag[i - 1] != 0) {
data_1.itag[k - 1] = data_1.itag[i - 1] + *itgi;
}
/*< 1 CONTINUE >*/
/* L1: */
}
/*< I1= N+1 >*/
i1 = data_1.n + 1;
/*< N= K >*/
data_1.n = k;
/*< 2 CONTINUE >*/
/* L2: */
}
/*< 3 IF( M.LT. M2) GOTO 6 >*/
L3:
if (data_1.m < data_1.m2) {
goto L6;
}
/*< I1= M2 >*/
i1 = data_1.m2;
/*< K= M >*/
k = data_1.m;
/*< LDI= LD+1 >*/
ldi = data_1.ld + 1;
/*< IF( NRPT.EQ.0) K= M1 >*/
if (*nrpt == 0) {
k = data_1.m1;
}
/*< DO 5 II=1, NRP >*/
i__1 = nrp;
for (ii = 1; ii <= i__1; ++ii) {
/*< DO 4 I= I1, M >*/
i__2 = data_1.m;
for (i = i1; i <= i__2; ++i) {
/*< K= K+1 >*/
++k;
/*< IR= LDI- I >*/
ir = ldi - i;
/*< KR= LDI- K >*/
kr = ldi - k;
/*< XI= X( IR) >*/
xi = data_1.x[ir - 1];
/*< YI= Y( IR) >*/
yi = data_1.y[ir - 1];
/*< ZI= Z( IR) >*/
zi = data_1.z[ir - 1];
/*< X( KR)= XI* XX+ YI* XY+ ZI* XZ+ XS >*/
d__2 = xi * xx + yi * xy;
d__1 = d__2 + zi * xz;
data_1.x[kr - 1] = d__1 + *xs;
/*< Y( KR)= XI* YX+ YI* YY+ ZI* YZ+ YS >*/
d__2 = xi * yx + yi * yy;
d__1 = d__2 + zi * yz;
data_1.y[kr - 1] = d__1 + *ys;
/*< Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ+ ZS >*/
d__2 = xi * zx + yi * zy;
d__1 = d__2 + zi * zz;
data_1.z[kr - 1] = d__1 + *zs;
/*< XI= T1X( IR) >*/
xi = t1x[ir - 1];
/*< YI= T1Y( IR) >*/
yi = t1y[ir - 1];
/*< ZI= T1Z( IR) >*/
zi = t1z[ir - 1];
/*< T1X( KR)= XI* XX+ YI* XY+ ZI* XZ >*/
d__1 = xi * xx + yi * xy;
t1x[kr - 1] = d__1 + zi * xz;
/*< T1Y( KR)= XI* YX+ YI* YY+ ZI* YZ >*/
d__1 = xi * yx + yi * yy;
t1y[kr - 1] = d__1 + zi * yz;
/*< T1Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ >*/
d__1 = xi * zx + yi * zy;
t1z[kr - 1] = d__1 + zi * zz;
/*< XI= T2X( IR) >*/
xi = t2x[ir - 1];
/*< YI= T2Y( IR) >*/
yi = t2y[ir - 1];
/*< ZI= T2Z( IR) >*/
zi = t2z[ir - 1];
/*< T2X( KR)= XI* XX+ YI* XY+ ZI* XZ >*/
d__1 = xi * xx + yi * xy;
t2x[kr - 1] = d__1 + zi * xz;
/*< T2Y( KR)= XI* YX+ YI* YY+ ZI* YZ >*/
d__1 = xi * yx + yi * yy;
t2y[kr - 1] = d__1 + zi * yz;
/*< T2Z( KR)= XI* ZX+ YI* ZY+ ZI* ZZ >*/
d__1 = xi * zx + yi * zy;
t2z[kr - 1] = d__1 + zi * zz;
/*< SALP( KR)= SALP( IR) >*/
angl_1.salp[kr - 1] = angl_1.salp[ir - 1];
/*< 4 BI( KR)= BI( IR) >*/
/* L4: */
data_1.bi[kr - 1] = data_1.bi[ir - 1];
}
/*< I1= M+1 >*/
i1 = data_1.m + 1;
/*< 5 M= K >*/
/* L5: */
data_1.m = k;
}
/*< 6 IF(( NRPT.EQ.0).AND.( IX.EQ.1)) RETURN >*/
L6:
if (*nrpt == 0 && ix == 1) {
return 0;
}
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< RETURN >*/
return 0;
/*< END >*/
} /* move_ */
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE NEFLD( XOB, YOB, ZOB, EX, EY, EZ) >*/
/* Subroutine */ int nefld_(xob, yob, zob, ex, ey, ez)
doublereal *xob, *yob, *zob;
doublecomplex *ex, *ey, *ez;
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Local variables */
extern /* Subroutine */ int efld_();
static integer i;
extern /* Subroutine */ int unere_();
static integer jc, jl;
static doublereal ax;
static integer ip;
static doublereal xi, zp;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex acx, bcx, ccx;
static integer ipr;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
/* *** */
/* NEFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER */
/* THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
/*< >*/
/*< >*/
/*< EX=(0.,0.) >*/
ex->r = 0., ex->i = 0.;
/*< EY=(0.,0.) >*/
ey->r = 0., ey->i = 0.;
/*< EZ=(0.,0.) >*/
ez->r = 0., ez->i = 0.;
/*< AX=0. >*/
ax = 0.;
/*< IF( N.EQ.0) GOTO 20 >*/
if (data_1.n == 0) {
goto L20;
}
/*< DO 1 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< XJ= XOB- X( I) >*/
dataj_1.xj = *xob - data_1.x[i - 1];
/*< YJ= YOB- Y( I) >*/
dataj_1.yj = *yob - data_1.y[i - 1];
/*< ZJ= ZOB- Z( I) >*/
dataj_1.zj = *zob - data_1.z[i - 1];
/*< ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ >*/
d__1 = cab[i - 1] * dataj_1.xj + sab[i - 1] * dataj_1.yj;
zp = d__1 + angl_1.salp[i - 1] * dataj_1.zj;
/*< IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1 >*/
if (abs(zp) > data_1.si[i - 1] * .5001) {
goto L1;
}
/*< ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP >*/
d__1 = dataj_1.xj * dataj_1.xj + dataj_1.yj * dataj_1.yj;
zp = d__1 + dataj_1.zj * dataj_1.zj - zp * zp;
/*< XJ= BI( I) >*/
dataj_1.xj = data_1.bi[i - 1];
/*< IF( ZP.GT.0.9* XJ* XJ) GOTO 1 >*/
d__1 = dataj_1.xj * .9;
if (zp > d__1 * dataj_1.xj) {
goto L1;
}
/*< AX= XJ >*/
ax = dataj_1.xj;
/*< GOTO 2 >*/
goto L2;
/*< 1 CONTINUE >*/
L1:
;
}
/*< 2 DO 19 I=1, N >*/
L2:
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< S= SI( I) >*/
dataj_1.s = data_1.si[i - 1];
/*< B= BI( I) >*/
dataj_1.b = data_1.bi[i - 1];
/*< XJ= X( I) >*/
dataj_1.xj = data_1.x[i - 1];
/*< YJ= Y( I) >*/
dataj_1.yj = data_1.y[i - 1];
/*< ZJ= Z( I) >*/
dataj_1.zj = data_1.z[i - 1];
/*< CABJ= CAB( I) >*/
dataj_1.cabj = cab[i - 1];
/*< SABJ= SAB( I) >*/
dataj_1.sabj = sab[i - 1];
/*< SALPJ= SALP( I) >*/
dataj_1.salpj = angl_1.salp[i - 1];
/*< IF( IEXK.EQ.0) GOTO 18 >*/
if (dataj_1.iexk == 0) {
goto L18;
}
/*< IPR= ICON1( I) >*/
ipr = data_1.icon1[i - 1];
/*< IF( IPR) 3,8,4 >*/
if (ipr < 0) {
goto L3;
} else if (ipr == 0) {
goto L8;
} else {
goto L4;
}
/*< 3 IPR=- IPR >*/
L3:
ipr = -ipr;
/*< IF(- ICON1( IPR).NE. I) GOTO 9 >*/
if (-data_1.icon1[ipr - 1] != i) {
goto L9;
}
/*< GOTO 6 >*/
goto L6;
/*< 4 IF( IPR.NE. I) GOTO 5 >*/
L4:
if (ipr != i) {
goto L5;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 9 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8)
{
goto L9;
}
/*< GOTO 7 >*/
goto L7;
/*< 5 IF( ICON2( IPR).NE. I) GOTO 9 >*/
L5:
if (data_1.icon2[ipr - 1] != i) {
goto L9;
}
/*< 6 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L6:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 9 >*/
if (xi < .999999) {
goto L9;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 9 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L9;
}
/*< 7 IND1=0 >*/
L7:
dataj_1.ind1 = 0;
/*< GOTO 10 >*/
goto L10;
/*< 8 IND1=1 >*/
L8:
dataj_1.ind1 = 1;
/*< GOTO 10 >*/
goto L10;
/*< 9 IND1=2 >*/
L9:
dataj_1.ind1 = 2;
/*< 10 IPR= ICON2( I) >*/
L10:
ipr = data_1.icon2[i - 1];
/*< IF( IPR) 11,16,12 >*/
if (ipr < 0) {
goto L11;
} else if (ipr == 0) {
goto L16;
} else {
goto L12;
}
/*< 11 IPR=- IPR >*/
L11:
ipr = -ipr;
/*< IF(- ICON2( IPR).NE. I) GOTO 17 >*/
if (-data_1.icon2[ipr - 1] != i) {
goto L17;
}
/*< GOTO 14 >*/
goto L14;
/*< 12 IF( IPR.NE. I) GOTO 13 >*/
L12:
if (ipr != i) {
goto L13;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 17 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8)
{
goto L17;
}
/*< GOTO 15 >*/
goto L15;
/*< 13 IF( ICON1( IPR).NE. I) GOTO 17 >*/
L13:
if (data_1.icon1[ipr - 1] != i) {
goto L17;
}
/*< 14 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L14:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 17 >*/
if (xi < .999999) {
goto L17;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 17 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L17;
}
/*< 15 IND2=0 >*/
L15:
dataj_1.ind2 = 0;
/*< GOTO 18 >*/
goto L18;
/*< 16 IND2=1 >*/
L16:
dataj_1.ind2 = 1;
/*< GOTO 18 >*/
goto L18;
/*< 17 IND2=2 >*/
L17:
dataj_1.ind2 = 2;
/*< 18 CONTINUE >*/
L18:
/*< CALL EFLD( XOB, YOB, ZOB, AX,1) >*/
efld_(xob, yob, zob, &ax, &c__1);
/*< ACX= CMPLX( AIR( I), AII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__3];
acx.r = z__1.r, acx.i = z__1.i;
/*< BCX= CMPLX( BIR( I), BII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__3];
bcx.r = z__1.r, bcx.i = z__1.i;
/*< CCX= CMPLX( CIR( I), CII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__3];
ccx.r = z__1.r, ccx.i = z__1.i;
/*< EX= EX+ EXK* ACX+ EXS* BCX+ EXC* CCX >*/
z__4.r = dataj_1.exk.r * acx.r - dataj_1.exk.i * acx.i, z__4.i =
dataj_1.exk.r * acx.i + dataj_1.exk.i * acx.r;
z__3.r = ex->r + z__4.r, z__3.i = ex->i + z__4.i;
z__5.r = dataj_1.exs.r * bcx.r - dataj_1.exs.i * bcx.i, z__5.i =
dataj_1.exs.r * bcx.i + dataj_1.exs.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.exc.r * ccx.r - dataj_1.exc.i * ccx.i, z__6.i =
dataj_1.exc.r * ccx.i + dataj_1.exc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
ex->r = z__1.r, ex->i = z__1.i;
/*< EY= EY+ EYK* ACX+ EYS* BCX+ EYC* CCX >*/
z__4.r = dataj_1.eyk.r * acx.r - dataj_1.eyk.i * acx.i, z__4.i =
dataj_1.eyk.r * acx.i + dataj_1.eyk.i * acx.r;
z__3.r = ey->r + z__4.r, z__3.i = ey->i + z__4.i;
z__5.r = dataj_1.eys.r * bcx.r - dataj_1.eys.i * bcx.i, z__5.i =
dataj_1.eys.r * bcx.i + dataj_1.eys.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.eyc.r * ccx.r - dataj_1.eyc.i * ccx.i, z__6.i =
dataj_1.eyc.r * ccx.i + dataj_1.eyc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
ey->r = z__1.r, ey->i = z__1.i;
/*< 19 EZ= EZ+ EZK* ACX+ EZS* BCX+ EZC* CCX >*/
/* L19: */
z__4.r = dataj_1.ezk.r * acx.r - dataj_1.ezk.i * acx.i, z__4.i =
dataj_1.ezk.r * acx.i + dataj_1.ezk.i * acx.r;
z__3.r = ez->r + z__4.r, z__3.i = ez->i + z__4.i;
z__5.r = dataj_1.ezs.r * bcx.r - dataj_1.ezs.i * bcx.i, z__5.i =
dataj_1.ezs.r * bcx.i + dataj_1.ezs.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.ezc.r * ccx.r - dataj_1.ezc.i * ccx.i, z__6.i =
dataj_1.ezc.r * ccx.i + dataj_1.ezc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
ez->r = z__1.r, ez->i = z__1.i;
}
/*< IF( M.EQ.0) RETURN >*/
if (data_1.m == 0) {
return 0;
}
/*< 20 JC= N >*/
L20:
jc = data_1.n;
/*< JL= LD+1 >*/
jl = data_1.ld + 1;
/*< DO 21 I=1, M >*/
i__1 = data_1.m;
for (i = 1; i <= i__1; ++i) {
/*< JL= JL-1 >*/
--jl;
/*< S= BI( JL) >*/
dataj_1.s = data_1.bi[jl - 1];
/*< XJ= X( JL) >*/
dataj_1.xj = data_1.x[jl - 1];
/*< YJ= Y( JL) >*/
dataj_1.yj = data_1.y[jl - 1];
/*< ZJ= Z( JL) >*/
dataj_1.zj = data_1.z[jl - 1];
/*< T1XJ= T1X( JL) >*/
*t1xj = t1x[jl - 1];
/*< T1YJ= T1Y( JL) >*/
*t1yj = t1y[jl - 1];
/*< T1ZJ= T1Z( JL) >*/
*t1zj = t1z[jl - 1];
/*< T2XJ= T2X( JL) >*/
*t2xj = t2x[jl - 1];
/*< T2YJ= T2Y( JL) >*/
*t2yj = t2y[jl - 1];
/*< T2ZJ= T2Z( JL) >*/
*t2zj = t2z[jl - 1];
/*< JC= JC+3 >*/
jc += 3;
/*< ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC) >*/
i__2 = jc - 3;
z__3.r = *t1xj * crnt_1.cur[i__2].r, z__3.i = *t1xj * crnt_1.cur[i__2]
.i;
i__3 = jc - 2;
z__4.r = *t1yj * crnt_1.cur[i__3].r, z__4.i = *t1yj * crnt_1.cur[i__3]
.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = jc - 1;
z__5.r = *t1zj * crnt_1.cur[i__4].r, z__5.i = *t1zj * crnt_1.cur[i__4]
.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
acx.r = z__1.r, acx.i = z__1.i;
/*< BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC) >*/
i__2 = jc - 3;
z__3.r = *t2xj * crnt_1.cur[i__2].r, z__3.i = *t2xj * crnt_1.cur[i__2]
.i;
i__3 = jc - 2;
z__4.r = *t2yj * crnt_1.cur[i__3].r, z__4.i = *t2yj * crnt_1.cur[i__3]
.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = jc - 1;
z__5.r = *t2zj * crnt_1.cur[i__4].r, z__5.i = *t2zj * crnt_1.cur[i__4]
.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
bcx.r = z__1.r, bcx.i = z__1.i;
/*< DO 21 IP=1, KSYMP >*/
i__2 = gnd_1.ksymp;
for (ip = 1; ip <= i__2; ++ip) {
/*< IPGND= IP >*/
dataj_1.ipgnd = ip;
/*< CALL UNERE( XOB, YOB, ZOB) >*/
unere_(xob, yob, zob);
/*< EX= EX+ ACX* EXK+ BCX* EXS >*/
z__3.r = acx.r * dataj_1.exk.r - acx.i * dataj_1.exk.i, z__3.i =
acx.r * dataj_1.exk.i + acx.i * dataj_1.exk.r;
z__2.r = ex->r + z__3.r, z__2.i = ex->i + z__3.i;
z__4.r = bcx.r * dataj_1.exs.r - bcx.i * dataj_1.exs.i, z__4.i =
bcx.r * dataj_1.exs.i + bcx.i * dataj_1.exs.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ex->r = z__1.r, ex->i = z__1.i;
/*< EY= EY+ ACX* EYK+ BCX* EYS >*/
z__3.r = acx.r * dataj_1.eyk.r - acx.i * dataj_1.eyk.i, z__3.i =
acx.r * dataj_1.eyk.i + acx.i * dataj_1.eyk.r;
z__2.r = ey->r + z__3.r, z__2.i = ey->i + z__3.i;
z__4.r = bcx.r * dataj_1.eys.r - bcx.i * dataj_1.eys.i, z__4.i =
bcx.r * dataj_1.eys.i + bcx.i * dataj_1.eys.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ey->r = z__1.r, ey->i = z__1.i;
/*< 21 EZ= EZ+ ACX* EZK+ BCX* EZS >*/
/* L21: */
z__3.r = acx.r * dataj_1.ezk.r - acx.i * dataj_1.ezk.i, z__3.i =
acx.r * dataj_1.ezk.i + acx.i * dataj_1.ezk.r;
z__2.r = ez->r + z__3.r, z__2.i = ez->i + z__3.i;
z__4.r = bcx.r * dataj_1.ezs.r - bcx.i * dataj_1.ezs.i, z__4.i =
bcx.r * dataj_1.ezs.i + bcx.i * dataj_1.ezs.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
ez->r = z__1.r, ez->i = z__1.i;
}
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* nefld_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE NETWK( CM, CMB, CMC, CMD, IP, EINC) >*/
/* Subroutine */ int netwk_(cm, cmb, cmc, cmd, ip, einc)
doublecomplex *cm, *cmb, *cmc, *cmd;
integer *ip;
doublecomplex *einc;
{
/* Initialized data */
static integer ndimn = 150;
static integer ndimnp = 151;
static doublereal tp = 6.283185308;
/* Format strings */
static char fmt_59[] = "(1x,\002ERROR - - NETWORK ARRAY DIMENSIONS TOO S\
MALL\002)";
static char fmt_58[] = "(///,3x,\002MAXIMUM RELATIVE ASYMMETRY OF THE DR\
IVING POINT\002,\002 ADMITTANCE MATRIX IS\002,1p,e10.3,\002 FOR SEGMENTS\002\
,i5,\002 AND\002,i5,/,3x,\002RMS RELATIVE ASYMMETRY IS\002,e10.3)";
static char fmt_61[] = "(///,27x,\002- - - STRUCTURE EXCITATION DATA AT \
NETWORK CONN\002,\002ECTION POINTS - - -\002)";
static char fmt_60[] = "(/,3x,\002TAG\002,3x,\002SEG.\002,4x,\002VOLTAGE\
(VOLTS)\002,9x,\002CURRENT (\002,\002AMPS)\002,9x,\002IMPEDANCE (OHMS)\002,\
8x,\002ADMITTANCE (MHOS)\002,6x,\002POWER\002,/,3x,\002NO.\002,3x,\002NO.\
\002,4x,\002REAL\002,8x,\002IMAG.\002,3(7x,\002REAL\002,8x,\002IMAG.\002),5x,\
\002(WATTS)\002)";
static char fmt_62[] = "(2(1x,i5),1p,9e12.5)";
static char fmt_63[] = "(///,42x,\002- - - ANTENNA INPUT PARAMETERS - \
- -\002)";
static char fmt_64[] = "(1x,i5,\002 *\002,i4,1p,9e12.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
void z_div();
double z_abs(), sqrt();
integer do_fio();
double sin(), cos();
void d_cnjg();
/* Local variables */
static integer neqt, nteq, ipnt[150];
static doublecomplex rhnt[150], vsrc[10], rhnx[150];
static integer ntsc;
static doublecomplex ymit;
static integer nseg1, nseg2, neqz2, irow1, irow2, i, j;
extern /* Subroutine */ int factr_();
static integer nteqa[150], ntsca[150];
extern /* Subroutine */ int solgf_(), solve_();
static doublereal asa;
static doublecomplex cmn[22500] /* was [150][150] */;
static doublereal asm_, y11i, y12i;
static doublecomplex rhs[1000], cux;
static integer nop;
static doublereal y11r, y12r, y22r, y22i;
static doublecomplex vlt;
static doublereal pwr;
static integer isc1, isc2;
extern /* Subroutine */ int cabc_();
/* Fortran I/O blocks */
static cilist io___1546 = { 0, 6, 0, fmt_59, 0 };
static cilist io___1555 = { 0, 6, 0, fmt_58, 0 };
static cilist io___1569 = { 0, 6, 0, fmt_59, 0 };
static cilist io___1571 = { 0, 6, 0, fmt_61, 0 };
static cilist io___1572 = { 0, 6, 0, fmt_60, 0 };
static cilist io___1575 = { 0, 6, 0, fmt_62, 0 };
static cilist io___1576 = { 0, 6, 0, fmt_62, 0 };
static cilist io___1577 = { 0, 6, 0, fmt_63, 0 };
static cilist io___1578 = { 0, 6, 0, fmt_60, 0 };
static cilist io___1579 = { 0, 6, 0, fmt_62, 0 };
static cilist io___1580 = { 0, 6, 0, fmt_64, 0 };
/* *** */
/* SUBROUTINE NETWK SOLVES FOR STRUCTURE CURRENTS FOR A GIVEN */
/* EXCITATION INCLUDING THE EFFECT OF NON-RADIATING NETWORKS IF */
/* PRESENT. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< DIMENSION EINC(1), IP(1), CM(1), CMB(1), CMC(1), CMD(1) >*/
/*< >*/
/*< DATA NDIMN, NDIMNP/150,151/, TP/6.283185308D+0/ >*/
/* Parameter adjustments */
--einc;
--ip;
--cmd;
--cmc;
--cmb;
--cm;
/* Function Body */
/*< NEQZ2= NEQ2 >*/
neqz2 = netcx_1.neq2;
/*< IF( NEQZ2.EQ.0) NEQZ2=1 >*/
if (neqz2 == 0) {
neqz2 = 1;
}
/*< PIN=0. >*/
netcx_1.pin = 0.;
/*< PNLS=0. >*/
netcx_1.pnls = 0.;
/*< NEQT= NEQ+ NEQ2 >*/
neqt = netcx_1.neq + netcx_1.neq2;
/*< IF( NTSOL.NE.0) GOTO 42 >*/
if (netcx_1.ntsol != 0) {
goto L42;
}
/*< NOP= NEQ/ NPEQ >*/
nop = netcx_1.neq / netcx_1.npeq;
/* COMPUTE RELATIVE MATRIX ASYMMETRY */
/*< IF( MASYM.EQ.0) GOTO 14 >*/
if (netcx_1.masym == 0) {
goto L14;
}
/*< IROW1=0 >*/
irow1 = 0;
/*< IF( NONET.EQ.0) GOTO 5 >*/
if (netcx_1.nonet == 0) {
goto L5;
}
/*< DO 4 I=1, NONET >*/
i__1 = netcx_1.nonet;
for (i = 1; i <= i__1; ++i) {
/*< NSEG1= ISEG1( I) >*/
nseg1 = netcx_1.iseg1[i - 1];
/*< DO 3 ISC1=1,2 >*/
for (isc1 = 1; isc1 <= 2; ++isc1) {
/*< IF( IROW1.EQ.0) GOTO 2 >*/
if (irow1 == 0) {
goto L2;
}
/*< DO 1 J=1, IROW1 >*/
i__2 = irow1;
for (j = 1; j <= i__2; ++j) {
/*< IF( NSEG1.EQ. IPNT( J)) GOTO 3 >*/
if (nseg1 == ipnt[j - 1]) {
goto L3;
}
/*< 1 CONTINUE >*/
/* L1: */
}
/*< 2 IROW1= IROW1+1 >*/
L2:
++irow1;
/*< IPNT( IROW1)= NSEG1 >*/
ipnt[irow1 - 1] = nseg1;
/*< 3 NSEG1= ISEG2( I) >*/
L3:
nseg1 = netcx_1.iseg2[i - 1];
}
/*< 4 CONTINUE >*/
/* L4: */
}
/*< 5 IF( NSANT.EQ.0) GOTO 9 >*/
L5:
if (vsorc_1.nsant == 0) {
goto L9;
}
/*< DO 8 I=1, NSANT >*/
i__1 = vsorc_1.nsant;
for (i = 1; i <= i__1; ++i) {
/*< NSEG1= ISANT( I) >*/
nseg1 = vsorc_1.isant[i - 1];
/*< IF( IROW1.EQ.0) GOTO 7 >*/
if (irow1 == 0) {
goto L7;
}
/*< DO 6 J=1, IROW1 >*/
i__2 = irow1;
for (j = 1; j <= i__2; ++j) {
/*< IF( NSEG1.EQ. IPNT( J)) GOTO 8 >*/
if (nseg1 == ipnt[j - 1]) {
goto L8;
}
/*< 6 CONTINUE >*/
/* L6: */
}
/*< 7 IROW1= IROW1+1 >*/
L7:
++irow1;
/*< IPNT( IROW1)= NSEG1 >*/
ipnt[irow1 - 1] = nseg1;
/*< 8 CONTINUE >*/
L8:
;
}
/*< 9 IF( IROW1.LT. NDIMNP) GOTO 10 >*/
L9:
if (irow1 < ndimnp) {
goto L10;
}
/*< WRITE( 6,59) >*/
s_wsfe(&io___1546);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 10 IF( IROW1.LT.2) GOTO 14 >*/
L10:
if (irow1 < 2) {
goto L14;
}
/*< DO 12 I=1, IROW1 >*/
i__1 = irow1;
for (i = 1; i <= i__1; ++i) {
/*< ISC1= IPNT( I) >*/
isc1 = ipnt[i - 1];
/*< ASM= SI( ISC1) >*/
asm_ = data_1.si[isc1 - 1];
/*< DO 11 J=1, NEQT >*/
i__2 = neqt;
for (j = 1; j <= i__2; ++j) {
/*< 11 RHS( J)=(0.,0.) >*/
/* L11: */
i__3 = j - 1;
rhs[i__3].r = 0., rhs[i__3].i = 0.;
}
/*< RHS( ISC1)=(1.,0.) >*/
i__3 = isc1 - 1;
rhs[i__3].r = 1., rhs[i__3].i = 0.;
/*< >*/
solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
netcx_1.neq, &netcx_1.neq2, &neqz2);
/*< CALL CABC( RHS) >*/
cabc_(rhs);
/*< DO 12 J=1, IROW1 >*/
i__3 = irow1;
for (j = 1; j <= i__3; ++j) {
/*< ISC1= IPNT( J) >*/
isc1 = ipnt[j - 1];
/*< 12 CMN( J, I)= RHS( ISC1)/ ASM >*/
/* L12: */
i__2 = j + i * 150 - 151;
i__4 = isc1 - 1;
z__1.r = rhs[i__4].r / asm_, z__1.i = rhs[i__4].i / asm_;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
}
}
/*< ASM=0. >*/
asm_ = 0.;
/*< ASA=0. >*/
asa = 0.;
/*< DO 13 I=2, IROW1 >*/
i__2 = irow1;
for (i = 2; i <= i__2; ++i) {
/*< ISC1= I-1 >*/
isc1 = i - 1;
/*< DO 13 J=1, ISC1 >*/
i__4 = isc1;
for (j = 1; j <= i__4; ++j) {
/*< CUX= CMN( I, J) >*/
i__3 = i + j * 150 - 151;
cux.r = cmn[i__3].r, cux.i = cmn[i__3].i;
/*< PWR= ABS(( CUX- CMN( J, I))/ CUX) >*/
i__3 = j + i * 150 - 151;
z__2.r = cux.r - cmn[i__3].r, z__2.i = cux.i - cmn[i__3].i;
z_div(&z__1, &z__2, &cux);
pwr = z_abs(&z__1);
/*< ASA= ASA+ PWR* PWR >*/
asa += pwr * pwr;
/*< IF( PWR.LT. ASM) GOTO 13 >*/
if (pwr < asm_) {
goto L13;
}
/*< ASM= PWR >*/
asm_ = pwr;
/*< NTEQ= IPNT( I) >*/
nteq = ipnt[i - 1];
/*< NTSC= IPNT( J) >*/
ntsc = ipnt[j - 1];
/*< 13 CONTINUE >*/
L13:
;
}
}
/*< ASA= SQRT( ASA*2./ DFLOAT( IROW1*( IROW1-1))) >*/
asa = sqrt(asa * 2. / (doublereal) (irow1 * (irow1 - 1)));
/*< WRITE( 6,58) ASM, NTEQ, NTSC, ASA >*/
s_wsfe(&io___1555);
do_fio(&c__1, (char *)&asm_, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&nteq, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&ntsc, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&asa, (ftnlen)sizeof(doublereal));
e_wsfe();
/* SOLUTION OF NETWORK EQUATIONS */
/*< 14 IF( NONET.EQ.0) GOTO 48 >*/
L14:
if (netcx_1.nonet == 0) {
goto L48;
}
/*< DO 15 I=1, NDIMN >*/
i__4 = ndimn;
for (i = 1; i <= i__4; ++i) {
/*< RHNX( I)=(0.,0.) >*/
i__2 = i - 1;
rhnx[i__2].r = 0., rhnx[i__2].i = 0.;
/*< DO 15 J=1, NDIMN >*/
i__2 = ndimn;
for (j = 1; j <= i__2; ++j) {
/*< 15 CMN( I, J)=(0.,0.) >*/
/* L15: */
i__3 = i + j * 150 - 151;
cmn[i__3].r = 0., cmn[i__3].i = 0.;
}
}
/*< NTEQ=0 >*/
nteq = 0;
/* SORT NETWORK AND SOURCE DATA AND ASSIGN EQUATION NUMBERS TO */
/* SEGMENTS. */
/*< NTSC=0 >*/
ntsc = 0;
/*< DO 38 J=1, NONET >*/
i__3 = netcx_1.nonet;
for (j = 1; j <= i__3; ++j) {
/*< NSEG1= ISEG1( J) >*/
nseg1 = netcx_1.iseg1[j - 1];
/*< NSEG2= ISEG2( J) >*/
nseg2 = netcx_1.iseg2[j - 1];
/*< IF( NTYP( J).GT.1) GOTO 16 >*/
if (netcx_1.ntyp[j - 1] > 1) {
goto L16;
}
/*< Y11R= X11R( J) >*/
y11r = netcx_1.x11r[j - 1];
/*< Y11I= X11I( J) >*/
y11i = netcx_1.x11i[j - 1];
/*< Y12R= X12R( J) >*/
y12r = netcx_1.x12r[j - 1];
/*< Y12I= X12I( J) >*/
y12i = netcx_1.x12i[j - 1];
/*< Y22R= X22R( J) >*/
y22r = netcx_1.x22r[j - 1];
/*< Y22I= X22I( J) >*/
y22i = netcx_1.x22i[j - 1];
/*< GOTO 17 >*/
goto L17;
/*< 16 Y22R= TP* X11I( J)/ WLAM >*/
L16:
y22r = tp * netcx_1.x11i[j - 1] / data_1.wlam;
/*< Y12R=0. >*/
y12r = 0.;
/*< Y12I=1./( X11R( J)* SIN( Y22R)) >*/
y12i = 1. / (netcx_1.x11r[j - 1] * sin(y22r));
/*< Y11R= X12R( J) >*/
y11r = netcx_1.x12r[j - 1];
/*< Y11I=- Y12I* COS( Y22R) >*/
y11i = -y12i * cos(y22r);
/*< Y22R= X22R( J) >*/
y22r = netcx_1.x22r[j - 1];
/*< Y22I= Y11I+ X22I( J) >*/
y22i = y11i + netcx_1.x22i[j - 1];
/*< Y11I= Y11I+ X12I( J) >*/
y11i += netcx_1.x12i[j - 1];
/*< IF( NTYP( J).EQ.2) GOTO 17 >*/
if (netcx_1.ntyp[j - 1] == 2) {
goto L17;
}
/*< Y12R=- Y12R >*/
y12r = -y12r;
/*< Y12I=- Y12I >*/
y12i = -y12i;
/*< 17 IF( NSANT.EQ.0) GOTO 19 >*/
L17:
if (vsorc_1.nsant == 0) {
goto L19;
}
/*< DO 18 I=1, NSANT >*/
i__2 = vsorc_1.nsant;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG1.NE. ISANT( I)) GOTO 18 >*/
if (nseg1 != vsorc_1.isant[i - 1]) {
goto L18;
}
/*< ISC1= I >*/
isc1 = i;
/*< GOTO 22 >*/
goto L22;
/*< 18 CONTINUE >*/
L18:
;
}
/*< 19 ISC1=0 >*/
L19:
isc1 = 0;
/*< IF( NTEQ.EQ.0) GOTO 21 >*/
if (nteq == 0) {
goto L21;
}
/*< DO 20 I=1, NTEQ >*/
i__2 = nteq;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG1.NE. NTEQA( I)) GOTO 20 >*/
if (nseg1 != nteqa[i - 1]) {
goto L20;
}
/*< IROW1= I >*/
irow1 = i;
/*< GOTO 25 >*/
goto L25;
/*< 20 CONTINUE >*/
L20:
;
}
/*< 21 NTEQ= NTEQ+1 >*/
L21:
++nteq;
/*< IROW1= NTEQ >*/
irow1 = nteq;
/*< NTEQA( NTEQ)= NSEG1 >*/
nteqa[nteq - 1] = nseg1;
/*< GOTO 25 >*/
goto L25;
/*< 22 IF( NTSC.EQ.0) GOTO 24 >*/
L22:
if (ntsc == 0) {
goto L24;
}
/*< DO 23 I=1, NTSC >*/
i__2 = ntsc;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG1.NE. NTSCA( I)) GOTO 23 >*/
if (nseg1 != ntsca[i - 1]) {
goto L23;
}
/*< IROW1= NDIMNP- I >*/
irow1 = ndimnp - i;
/*< GOTO 25 >*/
goto L25;
/*< 23 CONTINUE >*/
L23:
;
}
/*< 24 NTSC= NTSC+1 >*/
L24:
++ntsc;
/*< IROW1= NDIMNP- NTSC >*/
irow1 = ndimnp - ntsc;
/*< NTSCA( NTSC)= NSEG1 >*/
ntsca[ntsc - 1] = nseg1;
/*< VSRC( NTSC)= VSANT( ISC1) >*/
i__2 = ntsc - 1;
i__4 = isc1 - 1;
vsrc[i__2].r = vsorc_1.vsant[i__4].r, vsrc[i__2].i = vsorc_1.vsant[
i__4].i;
/*< 25 IF( NSANT.EQ.0) GOTO 27 >*/
L25:
if (vsorc_1.nsant == 0) {
goto L27;
}
/*< DO 26 I=1, NSANT >*/
i__2 = vsorc_1.nsant;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG2.NE. ISANT( I)) GOTO 26 >*/
if (nseg2 != vsorc_1.isant[i - 1]) {
goto L26;
}
/*< ISC2= I >*/
isc2 = i;
/*< GOTO 30 >*/
goto L30;
/*< 26 CONTINUE >*/
L26:
;
}
/*< 27 ISC2=0 >*/
L27:
isc2 = 0;
/*< IF( NTEQ.EQ.0) GOTO 29 >*/
if (nteq == 0) {
goto L29;
}
/*< DO 28 I=1, NTEQ >*/
i__2 = nteq;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG2.NE. NTEQA( I)) GOTO 28 >*/
if (nseg2 != nteqa[i - 1]) {
goto L28;
}
/*< IROW2= I >*/
irow2 = i;
/*< GOTO 33 >*/
goto L33;
/*< 28 CONTINUE >*/
L28:
;
}
/*< 29 NTEQ= NTEQ+1 >*/
L29:
++nteq;
/*< IROW2= NTEQ >*/
irow2 = nteq;
/*< NTEQA( NTEQ)= NSEG2 >*/
nteqa[nteq - 1] = nseg2;
/*< GOTO 33 >*/
goto L33;
/*< 30 IF( NTSC.EQ.0) GOTO 32 >*/
L30:
if (ntsc == 0) {
goto L32;
}
/*< DO 31 I=1, NTSC >*/
i__2 = ntsc;
for (i = 1; i <= i__2; ++i) {
/*< IF( NSEG2.NE. NTSCA( I)) GOTO 31 >*/
if (nseg2 != ntsca[i - 1]) {
goto L31;
}
/*< IROW2= NDIMNP- I >*/
irow2 = ndimnp - i;
/*< GOTO 33 >*/
goto L33;
/*< 31 CONTINUE >*/
L31:
;
}
/*< 32 NTSC= NTSC+1 >*/
L32:
++ntsc;
/*< IROW2= NDIMNP- NTSC >*/
irow2 = ndimnp - ntsc;
/*< NTSCA( NTSC)= NSEG2 >*/
ntsca[ntsc - 1] = nseg2;
/*< VSRC( NTSC)= VSANT( ISC2) >*/
i__2 = ntsc - 1;
i__4 = isc2 - 1;
vsrc[i__2].r = vsorc_1.vsant[i__4].r, vsrc[i__2].i = vsorc_1.vsant[
i__4].i;
/*< 33 IF( NTSC+ NTEQ.LT. NDIMNP) GOTO 34 >*/
L33:
if (ntsc + nteq < ndimnp) {
goto L34;
}
/*< WRITE( 6,59) >*/
s_wsfe(&io___1569);
e_wsfe();
/* FILL NETWORK EQUATION MATRIX AND RIGHT HAND SIDE VECTOR WITH */
/* NETWORK SHORT-CIRCUIT ADMITTANCE MATRIX COEFFICIENTS. */
/*< STOP >*/
s_stop("", 0L);
/*< 34 IF( ISC1.NE.0) GOTO 35 >*/
L34:
if (isc1 != 0) {
goto L35;
}
/*< >*/
i__2 = irow1 + irow1 * 150 - 151;
i__4 = irow1 + irow1 * 150 - 151;
z__3.r = y11r, z__3.i = y11i;
i__1 = nseg1 - 1;
z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
/*< >*/
i__2 = irow1 + irow2 * 150 - 151;
i__4 = irow1 + irow2 * 150 - 151;
z__3.r = y12r, z__3.i = y12i;
i__1 = nseg1 - 1;
z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
/*< GOTO 36 >*/
goto L36;
/*< >*/
L35:
i__2 = irow1 - 1;
i__4 = irow1 - 1;
z__4.r = y11r, z__4.i = y11i;
i__1 = isc1 - 1;
z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
.i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i *
vsorc_1.vsant[i__1].r;
z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
/*< >*/
i__2 = irow2 - 1;
i__4 = irow2 - 1;
z__4.r = y12r, z__4.i = y12i;
i__1 = isc1 - 1;
z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
.i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i *
vsorc_1.vsant[i__1].r;
z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
/*< 36 IF( ISC2.NE.0) GOTO 37 >*/
L36:
if (isc2 != 0) {
goto L37;
}
/*< >*/
i__2 = irow2 + irow2 * 150 - 151;
i__4 = irow2 + irow2 * 150 - 151;
z__3.r = y22r, z__3.i = y22i;
i__1 = nseg2 - 1;
z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
/*< >*/
i__2 = irow2 + irow1 * 150 - 151;
i__4 = irow2 + irow1 * 150 - 151;
z__3.r = y12r, z__3.i = y12i;
i__1 = nseg2 - 1;
z__2.r = data_1.si[i__1] * z__3.r, z__2.i = data_1.si[i__1] * z__3.i;
z__1.r = cmn[i__4].r - z__2.r, z__1.i = cmn[i__4].i - z__2.i;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
/*< GOTO 38 >*/
goto L38;
/*< >*/
L37:
i__2 = irow1 - 1;
i__4 = irow1 - 1;
z__4.r = y12r, z__4.i = y12i;
i__1 = isc2 - 1;
z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
.i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i *
vsorc_1.vsant[i__1].r;
z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
/*< >*/
i__2 = irow2 - 1;
i__4 = irow2 - 1;
z__4.r = y22r, z__4.i = y22i;
i__1 = isc2 - 1;
z__3.r = z__4.r * vsorc_1.vsant[i__1].r - z__4.i * vsorc_1.vsant[i__1]
.i, z__3.i = z__4.r * vsorc_1.vsant[i__1].i + z__4.i *
vsorc_1.vsant[i__1].r;
z__2.r = z__3.r / data_1.wlam, z__2.i = z__3.i / data_1.wlam;
z__1.r = rhnx[i__4].r + z__2.r, z__1.i = rhnx[i__4].i + z__2.i;
rhnx[i__2].r = z__1.r, rhnx[i__2].i = z__1.i;
/* ADD INTERACTION MATRIX ADMITTANCE ELEMENTS TO NETWORK EQUATION
*/
/* MATRIX */
/*< 38 CONTINUE >*/
L38:
;
}
/*< DO 41 I=1, NTEQ >*/
i__3 = nteq;
for (i = 1; i <= i__3; ++i) {
/*< DO 39 J=1, NEQT >*/
i__2 = neqt;
for (j = 1; j <= i__2; ++j) {
/*< 39 RHS( J)=(0.,0.) >*/
/* L39: */
i__4 = j - 1;
rhs[i__4].r = 0., rhs[i__4].i = 0.;
}
/*< IROW1= NTEQA( I) >*/
irow1 = nteqa[i - 1];
/*< RHS( IROW1)=(1.,0.) >*/
i__4 = irow1 - 1;
rhs[i__4].r = 1., rhs[i__4].i = 0.;
/*< >*/
solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
netcx_1.neq, &netcx_1.neq2, &neqz2);
/*< CALL CABC( RHS) >*/
cabc_(rhs);
/*< DO 40 J=1, NTEQ >*/
i__4 = nteq;
for (j = 1; j <= i__4; ++j) {
/*< IROW1= NTEQA( J) >*/
irow1 = nteqa[j - 1];
/*< 40 CMN( I, J)= CMN( I, J)+ RHS( IROW1) >*/
/* L40: */
i__2 = i + j * 150 - 151;
i__1 = i + j * 150 - 151;
i__5 = irow1 - 1;
z__1.r = cmn[i__1].r + rhs[i__5].r, z__1.i = cmn[i__1].i + rhs[
i__5].i;
cmn[i__2].r = z__1.r, cmn[i__2].i = z__1.i;
}
/* FACTOR NETWORK EQUATION MATRIX */
/*< 41 CONTINUE >*/
/* L41: */
}
/* ADD TO NETWORK EQUATION RIGHT HAND SIDE THE TERMS DUE TO ELEMENT */
/* INTERACTIONS */
/*< CALL FACTR( NTEQ, CMN, IPNT, NDIMN) >*/
factr_(&nteq, cmn, ipnt, &ndimn);
/*< 42 IF( NONET.EQ.0) GOTO 48 >*/
L42:
if (netcx_1.nonet == 0) {
goto L48;
}
/*< DO 43 I=1, NEQT >*/
i__3 = neqt;
for (i = 1; i <= i__3; ++i) {
/*< 43 RHS( I)= EINC( I) >*/
/* L43: */
i__2 = i - 1;
i__1 = i;
rhs[i__2].r = einc[i__1].r, rhs[i__2].i = einc[i__1].i;
}
/*< >*/
solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], rhs, &ip[1], &data_1.np, &
data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
netcx_1.neq, &netcx_1.neq2, &neqz2);
/*< CALL CABC( RHS) >*/
cabc_(rhs);
/*< DO 44 I=1, NTEQ >*/
i__2 = nteq;
for (i = 1; i <= i__2; ++i) {
/*< IROW1= NTEQA( I) >*/
irow1 = nteqa[i - 1];
/* SOLVE NETWORK EQUATIONS */
/*< 44 RHNT( I)= RHNX( I)+ RHS( IROW1) >*/
/* L44: */
i__1 = i - 1;
i__3 = i - 1;
i__5 = irow1 - 1;
z__1.r = rhnx[i__3].r + rhs[i__5].r, z__1.i = rhnx[i__3].i + rhs[i__5]
.i;
rhnt[i__1].r = z__1.r, rhnt[i__1].i = z__1.i;
}
/* ADD FIELDS DUE TO NETWORK VOLTAGES TO ELECTRIC FIELDS APPLIED TO */
/* STRUCTURE AND SOLVE FOR INDUCED CURRENT */
/*< CALL SOLVE( NTEQ, CMN, IPNT, RHNT, NDIMN) >*/
solve_(&nteq, cmn, ipnt, rhnt, &ndimn);
/*< DO 45 I=1, NTEQ >*/
i__1 = nteq;
for (i = 1; i <= i__1; ++i) {
/*< IROW1= NTEQA( I) >*/
irow1 = nteqa[i - 1];
/*< 45 EINC( IROW1)= EINC( IROW1)- RHNT( I) >*/
/* L45: */
i__3 = irow1;
i__5 = irow1;
i__2 = i - 1;
z__1.r = einc[i__5].r - rhnt[i__2].r, z__1.i = einc[i__5].i - rhnt[
i__2].i;
einc[i__3].r = z__1.r, einc[i__3].i = z__1.i;
}
/*< >*/
solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], &einc[1], &ip[1], &data_1.np, &
data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
netcx_1.neq, &netcx_1.neq2, &neqz2);
/*< CALL CABC( EINC) >*/
cabc_(&einc[1]);
/*< IF( NPRINT.EQ.0) WRITE( 6,61) >*/
if (netcx_1.nprint == 0) {
s_wsfe(&io___1571);
e_wsfe();
}
/*< IF( NPRINT.EQ.0) WRITE( 6,60) >*/
if (netcx_1.nprint == 0) {
s_wsfe(&io___1572);
e_wsfe();
}
/*< DO 46 I=1, NTEQ >*/
i__3 = nteq;
for (i = 1; i <= i__3; ++i) {
/*< IROW1= NTEQA( I) >*/
irow1 = nteqa[i - 1];
/*< VLT= RHNT( I)* SI( IROW1)* WLAM >*/
i__5 = i - 1;
i__2 = irow1 - 1;
z__2.r = data_1.si[i__2] * rhnt[i__5].r, z__2.i = data_1.si[i__2] *
rhnt[i__5].i;
z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
vlt.r = z__1.r, vlt.i = z__1.i;
/*< CUX= EINC( IROW1)* WLAM >*/
i__5 = irow1;
z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
.i;
cux.r = z__1.r, cux.i = z__1.i;
/*< YMIT= CUX/ VLT >*/
z_div(&z__1, &cux, &vlt);
ymit.r = z__1.r, ymit.i = z__1.i;
/*< ZPED= VLT/ CUX >*/
z_div(&z__1, &vlt, &cux);
netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
/*< IROW2= ITAG( IROW1) >*/
irow2 = data_1.itag[irow1 - 1];
/*< PWR=.5* REAL( VLT* CONJG( CUX)) >*/
d_cnjg(&z__2, &cux);
z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i +
vlt.i * z__2.r;
pwr = z__1.r * .5;
/*< PNLS= PNLS- PWR >*/
netcx_1.pnls -= pwr;
/*< >*/
/* L46: */
if (netcx_1.nprint == 0) {
s_wsfe(&io___1575);
do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&irow1, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/*< IF( NTSC.EQ.0) GOTO 49 >*/
if (ntsc == 0) {
goto L49;
}
/*< DO 47 I=1, NTSC >*/
i__3 = ntsc;
for (i = 1; i <= i__3; ++i) {
/*< IROW1= NTSCA( I) >*/
irow1 = ntsca[i - 1];
/*< VLT= VSRC( I) >*/
i__5 = i - 1;
vlt.r = vsrc[i__5].r, vlt.i = vsrc[i__5].i;
/*< CUX= EINC( IROW1)* WLAM >*/
i__5 = irow1;
z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
.i;
cux.r = z__1.r, cux.i = z__1.i;
/*< YMIT= CUX/ VLT >*/
z_div(&z__1, &cux, &vlt);
ymit.r = z__1.r, ymit.i = z__1.i;
/*< ZPED= VLT/ CUX >*/
z_div(&z__1, &vlt, &cux);
netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
/*< IROW2= ITAG( IROW1) >*/
irow2 = data_1.itag[irow1 - 1];
/*< PWR=.5* REAL( VLT* CONJG( CUX)) >*/
d_cnjg(&z__2, &cux);
z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i +
vlt.i * z__2.r;
pwr = z__1.r * .5;
/*< PNLS= PNLS- PWR >*/
netcx_1.pnls -= pwr;
/*< >*/
/* L47: */
if (netcx_1.nprint == 0) {
s_wsfe(&io___1576);
do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&irow1, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
/* SOLVE FOR CURRENTS WHEN NO NETWORKS ARE PRESENT */
/*< GOTO 49 >*/
goto L49;
/*< >*/
L48:
solgf_(&cm[1], &cmb[1], &cmc[1], &cmd[1], &einc[1], &ip[1], &data_1.np, &
data_1.n1, &data_1.n, &data_1.mp, &data_1.m1, &data_1.m, &
netcx_1.neq, &netcx_1.neq2, &neqz2);
/*< CALL CABC( EINC) >*/
cabc_(&einc[1]);
/*< NTSC=0 >*/
ntsc = 0;
/*< 49 IF( NSANT+ NVQD.EQ.0) RETURN >*/
L49:
if (vsorc_1.nsant + vsorc_1.nvqd == 0) {
return 0;
}
/*< WRITE( 6,63) >*/
s_wsfe(&io___1577);
e_wsfe();
/*< WRITE( 6,60) >*/
s_wsfe(&io___1578);
e_wsfe();
/*< IF( NSANT.EQ.0) GOTO 56 >*/
if (vsorc_1.nsant == 0) {
goto L56;
}
/*< DO 55 I=1, NSANT >*/
i__3 = vsorc_1.nsant;
for (i = 1; i <= i__3; ++i) {
/*< ISC1= ISANT( I) >*/
isc1 = vsorc_1.isant[i - 1];
/*< VLT= VSANT( I) >*/
i__5 = i - 1;
vlt.r = vsorc_1.vsant[i__5].r, vlt.i = vsorc_1.vsant[i__5].i;
/*< IF( NTSC.EQ.0) GOTO 51 >*/
if (ntsc == 0) {
goto L51;
}
/*< DO 50 J=1, NTSC >*/
i__5 = ntsc;
for (j = 1; j <= i__5; ++j) {
/*< IF( NTSCA( J).EQ. ISC1) GOTO 52 >*/
if (ntsca[j - 1] == isc1) {
goto L52;
}
/*< 50 CONTINUE >*/
/* L50: */
}
/*< 51 CUX= EINC( ISC1)* WLAM >*/
L51:
i__5 = isc1;
z__1.r = data_1.wlam * einc[i__5].r, z__1.i = data_1.wlam * einc[i__5]
.i;
cux.r = z__1.r, cux.i = z__1.i;
/*< IROW1=0 >*/
irow1 = 0;
/*< GOTO 54 >*/
goto L54;
/*< 52 IROW1= NDIMNP- J >*/
L52:
irow1 = ndimnp - j;
/*< CUX= RHNX( IROW1) >*/
i__5 = irow1 - 1;
cux.r = rhnx[i__5].r, cux.i = rhnx[i__5].i;
/*< DO 53 J=1, NTEQ >*/
i__5 = nteq;
for (j = 1; j <= i__5; ++j) {
/*< 53 CUX= CUX- CMN( J, IROW1)* RHNT( J) >*/
/* L53: */
i__2 = j + irow1 * 150 - 151;
i__1 = j - 1;
z__2.r = cmn[i__2].r * rhnt[i__1].r - cmn[i__2].i * rhnt[i__1].i,
z__2.i = cmn[i__2].r * rhnt[i__1].i + cmn[i__2].i * rhnt[
i__1].r;
z__1.r = cux.r - z__2.r, z__1.i = cux.i - z__2.i;
cux.r = z__1.r, cux.i = z__1.i;
}
/*< CUX=( EINC( ISC1)+ CUX)* WLAM >*/
i__2 = isc1;
z__2.r = einc[i__2].r + cux.r, z__2.i = einc[i__2].i + cux.i;
z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
cux.r = z__1.r, cux.i = z__1.i;
/*< 54 YMIT= CUX/ VLT >*/
L54:
z_div(&z__1, &cux, &vlt);
ymit.r = z__1.r, ymit.i = z__1.i;
/*< ZPED= VLT/ CUX >*/
z_div(&z__1, &vlt, &cux);
netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
/*< PWR=.5* REAL( VLT* CONJG( CUX)) >*/
d_cnjg(&z__2, &cux);
z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i +
vlt.i * z__2.r;
pwr = z__1.r * .5;
/*< PIN= PIN+ PWR >*/
netcx_1.pin += pwr;
/*< IF( IROW1.NE.0) PNLS= PNLS+ PWR >*/
if (irow1 != 0) {
netcx_1.pnls += pwr;
}
/*< IROW2= ITAG( ISC1) >*/
irow2 = data_1.itag[isc1 - 1];
/*< 55 WRITE( 6,62) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR >*/
/* L55: */
s_wsfe(&io___1579);
do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isc1, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/*< 56 IF( NVQD.EQ.0) RETURN >*/
L56:
if (vsorc_1.nvqd == 0) {
return 0;
}
/*< DO 57 I=1, NVQD >*/
i__3 = vsorc_1.nvqd;
for (i = 1; i <= i__3; ++i) {
/*< ISC1= IVQD( I) >*/
isc1 = vsorc_1.ivqd[i - 1];
/*< VLT= VQD( I) >*/
i__2 = i - 1;
vlt.r = vsorc_1.vqd[i__2].r, vlt.i = vsorc_1.vqd[i__2].i;
/*< CUX= CMPLX( AIR( ISC1), AII( ISC1)) >*/
i__2 = isc1 - 1;
i__1 = isc1 - 1;
z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__1];
cux.r = z__1.r, cux.i = z__1.i;
/*< YMIT= CMPLX( BIR( ISC1), BII( ISC1)) >*/
i__2 = isc1 - 1;
i__1 = isc1 - 1;
z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__1];
ymit.r = z__1.r, ymit.i = z__1.i;
/*< ZPED= CMPLX( CIR( ISC1), CII( ISC1)) >*/
i__2 = isc1 - 1;
i__1 = isc1 - 1;
z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__1];
netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
/*< PWR= SI( ISC1)* TP*.5 >*/
d__1 = data_1.si[isc1 - 1] * tp;
pwr = d__1 * .5;
/*< CUX=( CUX- YMIT* SIN( PWR)+ ZPED* COS( PWR))* WLAM >*/
d__1 = sin(pwr);
z__4.r = d__1 * ymit.r, z__4.i = d__1 * ymit.i;
z__3.r = cux.r - z__4.r, z__3.i = cux.i - z__4.i;
d__2 = cos(pwr);
z__5.r = d__2 * netcx_1.zped.r, z__5.i = d__2 * netcx_1.zped.i;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__1.r = data_1.wlam * z__2.r, z__1.i = data_1.wlam * z__2.i;
cux.r = z__1.r, cux.i = z__1.i;
/*< YMIT= CUX/ VLT >*/
z_div(&z__1, &cux, &vlt);
ymit.r = z__1.r, ymit.i = z__1.i;
/*< ZPED= VLT/ CUX >*/
z_div(&z__1, &vlt, &cux);
netcx_1.zped.r = z__1.r, netcx_1.zped.i = z__1.i;
/*< PWR=.5* REAL( VLT* CONJG( CUX)) >*/
d_cnjg(&z__2, &cux);
z__1.r = vlt.r * z__2.r - vlt.i * z__2.i, z__1.i = vlt.r * z__2.i +
vlt.i * z__2.r;
pwr = z__1.r * .5;
/*< PIN= PIN+ PWR >*/
netcx_1.pin += pwr;
/*< IROW2= ITAG( ISC1) >*/
irow2 = data_1.itag[isc1 - 1];
/*< 57 WRITE( 6,64) IROW2, ISC1, VLT, CUX, ZPED, YMIT, PWR >*/
/* L57: */
s_wsfe(&io___1580);
do_fio(&c__1, (char *)&irow2, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&isc1, (ftnlen)sizeof(integer));
do_fio(&c__2, (char *)&vlt, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&cux, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&netcx_1.zped, (ftnlen)sizeof(doublereal));
do_fio(&c__2, (char *)&ymit, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&pwr, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/*< RETURN >*/
return 0;
/*< >*/
/*< 59 FORMAT(1X,'ERROR - - NETWORK ARRAY DIMENSIONS TOO SMALL') >*/
/*< >*/
/*< >*/
/*< 62 FORMAT(2(1X,I5),1P,9E12.5) >*/
/*< 63 FORMAT(///,42X,'- - - ANTENNA INPUT PARAMETERS - - -') >*/
/*< 64 FORMAT(1X,I5,' *',I4,1P,9E12.5) >*/
/*< END >*/
} /* netwk_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE NFPAT >*/
/* Subroutine */ int nfpat_()
{
/* Initialized data */
static doublereal ta = .01745329252;
/* Format strings */
static char fmt_10[] = "(///,35x,\002- - - NEAR ELECTRIC FIELDS - - -\
\002,//,12x,\002- L\002,\002OCATION -\002,21x,\002- EX -\002,15x,\002- \
EY -\002,15x,\002- EZ -\002,/,8x,\002X\002,10x,\002Y\002,10x,\002Z\002,10\
x,\002MAGNITUDE\002,3x,\002PHASE\002,6x,\002MAGNITUDE\002,3x,\002PHASE\002,6\
x,\002MAGNITUDE\002,3x,\002PHASE\002,/,6x,\002METERS\002,5x,\002METERS\002,5\
x,\002METERS\002,8x,\002VOLTS/M\002,3x,\002DEGREES\002,6x,\002VOLTS/M\002,3x,\
\002DEGREES\002,6x,\002VOLTS/M\002,3x,\002DEGREES\002)";
static char fmt_12[] = "(///,35x,\002- - - NEAR MAGNETIC FIELDS - - -\
\002,//,12x,\002- L\002,\002OCATION -\002,21x,\002- HX -\002,15x,\002- \
HY -\002,15x,\002- HZ -\002,/,8x,\002X\002,10x,\002Y\002,10x,\002Z\002,10\
x,\002MAGNITUDE\002,3x,\002PHASE\002,6x,\002MAGNITUDE\002,3x,\002PHASE\002,6\
x,\002MAGNITUDE\002,3x,\002PHASE\002,/,6x,\002METERS\002,5x,\002METERS\002,5\
x,\002METERS\002,9x,\002AMPS/M\002,3x,\002DEGREES\002,7x,\002AMPS/M\002,3x\
,\002DEGREES\002,7x,\002AMPS/M\002,3x,\002DEGREES\002)";
static char fmt_11[] = "(2x,3(2x,f9.4),1x,3(3x,1p,e11.4,2x,0p,f7.2))";
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
double cos(), sin(), z_abs();
integer do_fio(), s_wsle(), do_lio(), e_wsle();
/* Local variables */
extern doublereal cang_();
static doublereal xnrt, ynrt, znrt;
static integer i, j;
extern /* Subroutine */ int nefld_(), nhfld_();
static integer kk;
static doublecomplex ex, ey, ez;
static doublereal cth, cph, xob, sph, yob, zob, sth, xxx, tmp1, tmp2,
tmp3, tmp4, tmp5, tmp6;
/* Fortran I/O blocks */
static cilist io___1582 = { 0, 6, 0, fmt_10, 0 };
static cilist io___1583 = { 0, 6, 0, fmt_12, 0 };
static cilist io___1606 = { 0, 6, 0, fmt_11, 0 };
static cilist io___1608 = { 0, 8, 0, 0, 0 };
static cilist io___1609 = { 0, 8, 0, 0, 0 };
static cilist io___1610 = { 0, 8, 0, 0, 0 };
static cilist io___1611 = { 0, 8, 0, 0, 0 };
static cilist io___1612 = { 0, 8, 0, 0, 0 };
static cilist io___1613 = { 0, 8, 0, 0, 0 };
static cilist io___1614 = { 0, 8, 0, 0, 0 };
static cilist io___1615 = { 0, 8, 0, 0, 0 };
/* *** */
/* COMPUTE NEAR E OR H FIELDS OVER A RANGE OF POINTS */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX EX, EY, EZ >*/
/*< >*/
/* *** */
/*< >*/
/* *** */
/*< COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
/*< DATA TA/1.745329252D-02/ >*/
/*< IF( NFEH.EQ.1) GOTO 1 >*/
if (fpat_1.nfeh == 1) {
goto L1;
}
/*< WRITE( 6,10) >*/
s_wsfe(&io___1582);
e_wsfe();
/*< GOTO 2 >*/
goto L2;
/*< 1 WRITE( 6,12) >*/
L1:
s_wsfe(&io___1583);
e_wsfe();
/*< 2 ZNRT= ZNR- DZNR >*/
L2:
znrt = fpat_1.znr - fpat_1.dznr;
/*< DO 9 I=1, NRZ >*/
i__1 = fpat_1.nrz;
for (i = 1; i <= i__1; ++i) {
/*< ZNRT= ZNRT+ DZNR >*/
znrt += fpat_1.dznr;
/*< IF( NEAR.EQ.0) GOTO 3 >*/
if (fpat_1.near == 0) {
goto L3;
}
/*< CTH= COS( TA* ZNRT) >*/
cth = cos(ta * znrt);
/*< STH= SIN( TA* ZNRT) >*/
sth = sin(ta * znrt);
/*< 3 YNRT= YNR- DYNR >*/
L3:
ynrt = fpat_1.ynr - fpat_1.dynr;
/*< DO 9 J=1, NRY >*/
i__2 = fpat_1.nry;
for (j = 1; j <= i__2; ++j) {
/*< YNRT= YNRT+ DYNR >*/
ynrt += fpat_1.dynr;
/*< IF( NEAR.EQ.0) GOTO 4 >*/
if (fpat_1.near == 0) {
goto L4;
}
/*< CPH= COS( TA* YNRT) >*/
cph = cos(ta * ynrt);
/*< SPH= SIN( TA* YNRT) >*/
sph = sin(ta * ynrt);
/*< 4 XNRT= XNR- DXNR >*/
L4:
xnrt = fpat_1.xnr - fpat_1.dxnr;
/*< DO 9 KK=1, NRX >*/
i__3 = fpat_1.nrx;
for (kk = 1; kk <= i__3; ++kk) {
/*< XNRT= XNRT+ DXNR >*/
xnrt += fpat_1.dxnr;
/*< IF( NEAR.EQ.0) GOTO 5 >*/
if (fpat_1.near == 0) {
goto L5;
}
/*< XOB= XNRT* STH* CPH >*/
d__1 = xnrt * sth;
xob = d__1 * cph;
/*< YOB= XNRT* STH* SPH >*/
d__1 = xnrt * sth;
yob = d__1 * sph;
/*< ZOB= XNRT* CTH >*/
zob = xnrt * cth;
/*< GOTO 6 >*/
goto L6;
/*< 5 XOB= XNRT >*/
L5:
xob = xnrt;
/*< YOB= YNRT >*/
yob = ynrt;
/*< ZOB= ZNRT >*/
zob = znrt;
/*< 6 TMP1= XOB/ WLAM >*/
L6:
tmp1 = xob / data_1.wlam;
/*< TMP2= YOB/ WLAM >*/
tmp2 = yob / data_1.wlam;
/*< TMP3= ZOB/ WLAM >*/
tmp3 = zob / data_1.wlam;
/*< IF( NFEH.EQ.1) GOTO 7 >*/
if (fpat_1.nfeh == 1) {
goto L7;
}
/*< CALL NEFLD( TMP1, TMP2, TMP3, EX, EY, EZ) >*/
nefld_(&tmp1, &tmp2, &tmp3, &ex, &ey, &ez);
/*< GOTO 8 >*/
goto L8;
/*< 7 CALL NHFLD( TMP1, TMP2, TMP3, EX, EY, EZ) >*/
L7:
nhfld_(&tmp1, &tmp2, &tmp3, &ex, &ey, &ez);
/*< 8 TMP1= ABS( EX) >*/
L8:
tmp1 = z_abs(&ex);
/*< TMP2= CANG( EX) >*/
tmp2 = cang_(&ex);
/*< TMP3= ABS( EY) >*/
tmp3 = z_abs(&ey);
/*< TMP4= CANG( EY) >*/
tmp4 = cang_(&ey);
/*< TMP5= ABS( EZ) >*/
tmp5 = z_abs(&ez);
/*< TMP6= CANG( EZ) >*/
tmp6 = cang_(&ez);
/* *** */
/*< WRITE( 6,11) XOB, YOB, ZOB, TMP1, TMP2, TMP3, TMP4, TMP5, TMP6 >*/
s_wsfe(&io___1606);
do_fio(&c__1, (char *)&xob, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&yob, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&zob, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IPLP1.NE.2) GOTO 9 >*/
if (plot_1.iplp1 != 2) {
goto L9;
}
/*< GOTO (14,15,16), IPLP4 >*/
switch ((int)plot_1.iplp4) {
case 1: goto L14;
case 2: goto L15;
case 3: goto L16;
}
/*< 14 XXX= XOB >*/
L14:
xxx = xob;
/*< GOTO 17 >*/
goto L17;
/*< 15 XXX= YOB >*/
L15:
xxx = yob;
/*< GOTO 17 >*/
goto L17;
/*< 16 XXX= ZOB >*/
L16:
xxx = zob;
/*< 17 CONTINUE >*/
L17:
/*< IF( IPLP2.NE.2) GOTO 13 >*/
if (plot_1.iplp2 != 2) {
goto L13;
}
/*< IF( IPLP3.EQ.1) WRITE( 8,*) XXX, TMP1, TMP2 >*/
if (plot_1.iplp3 == 1) {
s_wsle(&io___1608);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp1, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp2, (ftnlen)sizeof(
doublereal));
e_wsle();
}
/*< IF( IPLP3.EQ.2) WRITE( 8,*) XXX, TMP3, TMP4 >*/
if (plot_1.iplp3 == 2) {
s_wsle(&io___1609);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp3, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp4, (ftnlen)sizeof(
doublereal));
e_wsle();
}
/*< IF( IPLP3.EQ.3) WRITE( 8,*) XXX, TMP5, TMP6 >*/
if (plot_1.iplp3 == 3) {
s_wsle(&io___1610);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(
doublereal));
e_wsle();
}
/*< >*/
if (plot_1.iplp3 == 4) {
s_wsle(&io___1611);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp1, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp2, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp3, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp4, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(
doublereal));
do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(
doublereal));
e_wsle();
}
/*< GOTO 9 >*/
goto L9;
/*< 13 IF( IPLP2.NE.1) GOTO 9 >*/
L13:
if (plot_1.iplp2 != 1) {
goto L9;
}
/*< IF( IPLP3.EQ.1) WRITE( 8,*) XXX, EX >*/
if (plot_1.iplp3 == 1) {
s_wsle(&io___1612);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(
doublecomplex));
e_wsle();
}
/*< IF( IPLP3.EQ.2) WRITE( 8,*) XXX, EY >*/
if (plot_1.iplp3 == 2) {
s_wsle(&io___1613);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(
doublecomplex));
e_wsle();
}
/*< IF( IPLP3.EQ.3) WRITE( 8,*) XXX, EZ >*/
if (plot_1.iplp3 == 3) {
s_wsle(&io___1614);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(
doublecomplex));
e_wsle();
}
/* *** */
/*< IF( IPLP3.EQ.4) WRITE( 8,*) XXX, EX, EY, EZ >*/
if (plot_1.iplp3 == 4) {
s_wsle(&io___1615);
do_lio(&c__5, &c__1, (char *)&xxx, (ftnlen)sizeof(
doublereal));
do_lio(&c__7, &c__1, (char *)&ex, (ftnlen)sizeof(
doublecomplex));
do_lio(&c__7, &c__1, (char *)&ey, (ftnlen)sizeof(
doublecomplex));
do_lio(&c__7, &c__1, (char *)&ez, (ftnlen)sizeof(
doublecomplex));
e_wsle();
}
/*< 9 CONTINUE >*/
L9:
;
}
}
}
/*< RETURN >*/
return 0;
/*< >*/
/*< 11 FORMAT(2X,3(2X,F9.4),1X,3(3X,1P,E11.4,2X,0P,F7.2)) >*/
/*< >*/
/*< END >*/
} /* nfpat_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE NHFLD( XOB, YOB, ZOB, HX, HY, HZ) >*/
/* Subroutine */ int nhfld_(xob, yob, zob, hx, hy, hz)
doublereal *xob, *yob, *zob;
doublecomplex *hx, *hy, *hz;
{
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
/* Local variables */
static integer i;
extern /* Subroutine */ int hsfld_(), hintg_();
static integer jc, jl;
static doublereal ax, zp;
#define xs ((doublereal *)&data_1)
#define ys ((doublereal *)&data_1 + 600)
#define zs ((doublereal *)&data_1 + 1200)
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex acx, bcx, ccx;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
/* *** */
/* NHFLD COMPUTES THE NEAR FIELD AT SPECIFIED POINTS IN SPACE AFTER */
/* THE STRUCTURE CURRENTS HAVE BEEN COMPUTED. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< DIMENSION CAB(1), SAB(1) >*/
/*< >*/
/*< >*/
/*< >*/
/*< EQUIVALENCE(CAB,ALP),(SAB,BET) >*/
/*< HX=(0.,0.) >*/
hx->r = 0., hx->i = 0.;
/*< HY=(0.,0.) >*/
hy->r = 0., hy->i = 0.;
/*< HZ=(0.,0.) >*/
hz->r = 0., hz->i = 0.;
/*< AX=0. >*/
ax = 0.;
/*< IF( N.EQ.0) GOTO 4 >*/
if (data_1.n == 0) {
goto L4;
}
/*< DO 1 I=1, N >*/
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< XJ= XOB- X( I) >*/
dataj_1.xj = *xob - data_1.x[i - 1];
/*< YJ= YOB- Y( I) >*/
dataj_1.yj = *yob - data_1.y[i - 1];
/*< ZJ= ZOB- Z( I) >*/
dataj_1.zj = *zob - data_1.z[i - 1];
/*< ZP= CAB( I)* XJ+ SAB( I)* YJ+ SALP( I)* ZJ >*/
d__1 = cab[i - 1] * dataj_1.xj + sab[i - 1] * dataj_1.yj;
zp = d__1 + angl_1.salp[i - 1] * dataj_1.zj;
/*< IF( ABS( ZP).GT.0.5001* SI( I)) GOTO 1 >*/
if (abs(zp) > data_1.si[i - 1] * .5001) {
goto L1;
}
/*< ZP= XJ* XJ+ YJ* YJ+ ZJ* ZJ- ZP* ZP >*/
d__1 = dataj_1.xj * dataj_1.xj + dataj_1.yj * dataj_1.yj;
zp = d__1 + dataj_1.zj * dataj_1.zj - zp * zp;
/*< XJ= BI( I) >*/
dataj_1.xj = data_1.bi[i - 1];
/*< IF( ZP.GT.0.9* XJ* XJ) GOTO 1 >*/
d__1 = dataj_1.xj * .9;
if (zp > d__1 * dataj_1.xj) {
goto L1;
}
/*< AX= XJ >*/
ax = dataj_1.xj;
/*< GOTO 2 >*/
goto L2;
/*< 1 CONTINUE >*/
L1:
;
}
/*< 2 DO 3 I=1, N >*/
L2:
i__1 = data_1.n;
for (i = 1; i <= i__1; ++i) {
/*< S= SI( I) >*/
dataj_1.s = data_1.si[i - 1];
/*< B= BI( I) >*/
dataj_1.b = data_1.bi[i - 1];
/*< XJ= X( I) >*/
dataj_1.xj = data_1.x[i - 1];
/*< YJ= Y( I) >*/
dataj_1.yj = data_1.y[i - 1];
/*< ZJ= Z( I) >*/
dataj_1.zj = data_1.z[i - 1];
/*< CABJ= CAB( I) >*/
dataj_1.cabj = cab[i - 1];
/*< SABJ= SAB( I) >*/
dataj_1.sabj = sab[i - 1];
/*< SALPJ= SALP( I) >*/
dataj_1.salpj = angl_1.salp[i - 1];
/*< CALL HSFLD( XOB, YOB, ZOB, AX) >*/
hsfld_(xob, yob, zob, &ax);
/*< ACX= CMPLX( AIR( I), AII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.air[i__2], z__1.i = crnt_1.aii[i__3];
acx.r = z__1.r, acx.i = z__1.i;
/*< BCX= CMPLX( BIR( I), BII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.bir[i__2], z__1.i = crnt_1.bii[i__3];
bcx.r = z__1.r, bcx.i = z__1.i;
/*< CCX= CMPLX( CIR( I), CII( I)) >*/
i__2 = i - 1;
i__3 = i - 1;
z__1.r = crnt_1.cir[i__2], z__1.i = crnt_1.cii[i__3];
ccx.r = z__1.r, ccx.i = z__1.i;
/*< HX= HX+ EXK* ACX+ EXS* BCX+ EXC* CCX >*/
z__4.r = dataj_1.exk.r * acx.r - dataj_1.exk.i * acx.i, z__4.i =
dataj_1.exk.r * acx.i + dataj_1.exk.i * acx.r;
z__3.r = hx->r + z__4.r, z__3.i = hx->i + z__4.i;
z__5.r = dataj_1.exs.r * bcx.r - dataj_1.exs.i * bcx.i, z__5.i =
dataj_1.exs.r * bcx.i + dataj_1.exs.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.exc.r * ccx.r - dataj_1.exc.i * ccx.i, z__6.i =
dataj_1.exc.r * ccx.i + dataj_1.exc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
hx->r = z__1.r, hx->i = z__1.i;
/*< HY= HY+ EYK* ACX+ EYS* BCX+ EYC* CCX >*/
z__4.r = dataj_1.eyk.r * acx.r - dataj_1.eyk.i * acx.i, z__4.i =
dataj_1.eyk.r * acx.i + dataj_1.eyk.i * acx.r;
z__3.r = hy->r + z__4.r, z__3.i = hy->i + z__4.i;
z__5.r = dataj_1.eys.r * bcx.r - dataj_1.eys.i * bcx.i, z__5.i =
dataj_1.eys.r * bcx.i + dataj_1.eys.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.eyc.r * ccx.r - dataj_1.eyc.i * ccx.i, z__6.i =
dataj_1.eyc.r * ccx.i + dataj_1.eyc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
hy->r = z__1.r, hy->i = z__1.i;
/*< 3 HZ= HZ+ EZK* ACX+ EZS* BCX+ EZC* CCX >*/
/* L3: */
z__4.r = dataj_1.ezk.r * acx.r - dataj_1.ezk.i * acx.i, z__4.i =
dataj_1.ezk.r * acx.i + dataj_1.ezk.i * acx.r;
z__3.r = hz->r + z__4.r, z__3.i = hz->i + z__4.i;
z__5.r = dataj_1.ezs.r * bcx.r - dataj_1.ezs.i * bcx.i, z__5.i =
dataj_1.ezs.r * bcx.i + dataj_1.ezs.i * bcx.r;
z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i;
z__6.r = dataj_1.ezc.r * ccx.r - dataj_1.ezc.i * ccx.i, z__6.i =
dataj_1.ezc.r * ccx.i + dataj_1.ezc.i * ccx.r;
z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i;
hz->r = z__1.r, hz->i = z__1.i;
}
/*< IF( M.EQ.0) RETURN >*/
if (data_1.m == 0) {
return 0;
}
/*< 4 JC= N >*/
L4:
jc = data_1.n;
/*< JL= LD+1 >*/
jl = data_1.ld + 1;
/*< DO 5 I=1, M >*/
i__1 = data_1.m;
for (i = 1; i <= i__1; ++i) {
/*< JL= JL-1 >*/
--jl;
/*< S= BI( JL) >*/
dataj_1.s = data_1.bi[jl - 1];
/*< XJ= X( JL) >*/
dataj_1.xj = data_1.x[jl - 1];
/*< YJ= Y( JL) >*/
dataj_1.yj = data_1.y[jl - 1];
/*< ZJ= Z( JL) >*/
dataj_1.zj = data_1.z[jl - 1];
/*< T1XJ= T1X( JL) >*/
*t1xj = t1x[jl - 1];
/*< T1YJ= T1Y( JL) >*/
*t1yj = t1y[jl - 1];
/*< T1ZJ= T1Z( JL) >*/
*t1zj = t1z[jl - 1];
/*< T2XJ= T2X( JL) >*/
*t2xj = t2x[jl - 1];
/*< T2YJ= T2Y( JL) >*/
*t2yj = t2y[jl - 1];
/*< T2ZJ= T2Z( JL) >*/
*t2zj = t2z[jl - 1];
/*< CALL HINTG( XOB, YOB, ZOB) >*/
hintg_(xob, yob, zob);
/*< JC= JC+3 >*/
jc += 3;
/*< ACX= T1XJ* CUR( JC-2)+ T1YJ* CUR( JC-1)+ T1ZJ* CUR( JC) >*/
i__2 = jc - 3;
z__3.r = *t1xj * crnt_1.cur[i__2].r, z__3.i = *t1xj * crnt_1.cur[i__2]
.i;
i__3 = jc - 2;
z__4.r = *t1yj * crnt_1.cur[i__3].r, z__4.i = *t1yj * crnt_1.cur[i__3]
.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = jc - 1;
z__5.r = *t1zj * crnt_1.cur[i__4].r, z__5.i = *t1zj * crnt_1.cur[i__4]
.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
acx.r = z__1.r, acx.i = z__1.i;
/*< BCX= T2XJ* CUR( JC-2)+ T2YJ* CUR( JC-1)+ T2ZJ* CUR( JC) >*/
i__2 = jc - 3;
z__3.r = *t2xj * crnt_1.cur[i__2].r, z__3.i = *t2xj * crnt_1.cur[i__2]
.i;
i__3 = jc - 2;
z__4.r = *t2yj * crnt_1.cur[i__3].r, z__4.i = *t2yj * crnt_1.cur[i__3]
.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
i__4 = jc - 1;
z__5.r = *t2zj * crnt_1.cur[i__4].r, z__5.i = *t2zj * crnt_1.cur[i__4]
.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
bcx.r = z__1.r, bcx.i = z__1.i;
/*< HX= HX+ ACX* EXK+ BCX* EXS >*/
z__3.r = acx.r * dataj_1.exk.r - acx.i * dataj_1.exk.i, z__3.i =
acx.r * dataj_1.exk.i + acx.i * dataj_1.exk.r;
z__2.r = hx->r + z__3.r, z__2.i = hx->i + z__3.i;
z__4.r = bcx.r * dataj_1.exs.r - bcx.i * dataj_1.exs.i, z__4.i =
bcx.r * dataj_1.exs.i + bcx.i * dataj_1.exs.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
hx->r = z__1.r, hx->i = z__1.i;
/*< HY= HY+ ACX* EYK+ BCX* EYS >*/
z__3.r = acx.r * dataj_1.eyk.r - acx.i * dataj_1.eyk.i, z__3.i =
acx.r * dataj_1.eyk.i + acx.i * dataj_1.eyk.r;
z__2.r = hy->r + z__3.r, z__2.i = hy->i + z__3.i;
z__4.r = bcx.r * dataj_1.eys.r - bcx.i * dataj_1.eys.i, z__4.i =
bcx.r * dataj_1.eys.i + bcx.i * dataj_1.eys.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
hy->r = z__1.r, hy->i = z__1.i;
/*< 5 HZ= HZ+ ACX* EZK+ BCX* EZS >*/
/* L5: */
z__3.r = acx.r * dataj_1.ezk.r - acx.i * dataj_1.ezk.i, z__3.i =
acx.r * dataj_1.ezk.i + acx.i * dataj_1.ezk.r;
z__2.r = hz->r + z__3.r, z__2.i = hz->i + z__3.i;
z__4.r = bcx.r * dataj_1.ezs.r - bcx.i * dataj_1.ezs.i, z__4.i =
bcx.r * dataj_1.ezs.i + bcx.i * dataj_1.ezs.r;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
hz->r = z__1.r, hz->i = z__1.i;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* nhfld_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
#undef sab
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef zs
#undef ys
#undef xs
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int patch_0_(n__, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3,
x4, y4, z4)
int n__;
integer *nx, *ny;
doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
{
/* Format strings */
static char fmt_14[] = "(\002 ERROR -- CORNERS OF QUADRILATERAL PATCH DO\
NOT LIE IN \002,\002A PLANE\002)";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double cos(), sin(), sqrt();
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static doublereal saln, salpn;
static integer mi;
static doublereal xa;
static integer ix, iy;
static doublereal xs, ys, zs, xt, yt, zt, xn2, yn2, zn2, s1x;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
static doublereal s1y, s1z, s2x, s2y, s2z;
static integer mia, ntp, nxp, nyp;
static doublereal xnv, ynv, znv, xst;
/* Fortran I/O blocks */
static cilist io___1664 = { 0, 6, 0, fmt_14, 0 };
/* *** */
/* PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/* NEW PATCHES. FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY) */
/* ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL. */
/* FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH */
/* NX BY NY RECTANGULAR PATCHES. */
/*< >*/
/*< M= M+1 >*/
switch(n__) {
case 1: goto L_subph;
}
++data_1.m;
/*< MI= LD+1- M >*/
mi = data_1.ld + 1 - data_1.m;
/*< NTP= NY >*/
ntp = *ny;
/*< IF( NX.GT.0) NTP=2 >*/
if (*nx > 0) {
ntp = 2;
}
/*< IF( NTP.GT.1) GOTO 2 >*/
if (ntp > 1) {
goto L2;
}
/*< X( MI)= X1 >*/
data_1.x[mi - 1] = *x1;
/*< Y( MI)= Y1 >*/
data_1.y[mi - 1] = *y1;
/*< Z( MI)= Z1 >*/
data_1.z[mi - 1] = *z1;
/*< BI( MI)= Z2 >*/
data_1.bi[mi - 1] = *z2;
/*< ZNV= COS( X2) >*/
znv = cos(*x2);
/*< XNV= ZNV* COS( Y2) >*/
xnv = znv * cos(*y2);
/*< YNV= ZNV* SIN( Y2) >*/
ynv = znv * sin(*y2);
/*< ZNV= SIN( X2) >*/
znv = sin(*x2);
/*< XA= SQRT( XNV* XNV+ YNV* YNV) >*/
xa = sqrt(xnv * xnv + ynv * ynv);
/*< IF( XA.LT.1.D-6) GOTO 1 >*/
if (xa < 1e-6) {
goto L1;
}
/*< T1X( MI)=- YNV/ XA >*/
t1x[mi - 1] = -ynv / xa;
/*< T1Y( MI)= XNV/ XA >*/
t1y[mi - 1] = xnv / xa;
/*< T1Z( MI)=0. >*/
t1z[mi - 1] = 0.;
/*< GOTO 6 >*/
goto L6;
/*< 1 T1X( MI)=1. >*/
L1:
t1x[mi - 1] = 1.;
/*< T1Y( MI)=0. >*/
t1y[mi - 1] = 0.;
/*< T1Z( MI)=0. >*/
t1z[mi - 1] = 0.;
/*< GOTO 6 >*/
goto L6;
/*< 2 S1X= X2- X1 >*/
L2:
s1x = *x2 - *x1;
/*< S1Y= Y2- Y1 >*/
s1y = *y2 - *y1;
/*< S1Z= Z2- Z1 >*/
s1z = *z2 - *z1;
/*< S2X= X3- X2 >*/
s2x = *x3 - *x2;
/*< S2Y= Y3- Y2 >*/
s2y = *y3 - *y2;
/*< S2Z= Z3- Z2 >*/
s2z = *z3 - *z2;
/*< IF( NX.EQ.0) GOTO 3 >*/
if (*nx == 0) {
goto L3;
}
/*< S1X= S1X/ NX >*/
s1x /= *nx;
/*< S1Y= S1Y/ NX >*/
s1y /= *nx;
/*< S1Z= S1Z/ NX >*/
s1z /= *nx;
/*< S2X= S2X/ NY >*/
s2x /= *ny;
/*< S2Y= S2Y/ NY >*/
s2y /= *ny;
/*< S2Z= S2Z/ NY >*/
s2z /= *ny;
/*< 3 XNV= S1Y* S2Z- S1Z* S2Y >*/
L3:
xnv = s1y * s2z - s1z * s2y;
/*< YNV= S1Z* S2X- S1X* S2Z >*/
ynv = s1z * s2x - s1x * s2z;
/*< ZNV= S1X* S2Y- S1Y* S2X >*/
znv = s1x * s2y - s1y * s2x;
/*< XA= SQRT( XNV* XNV+ YNV* YNV+ ZNV* ZNV) >*/
d__1 = xnv * xnv + ynv * ynv;
xa = sqrt(d__1 + znv * znv);
/*< XNV= XNV/ XA >*/
xnv /= xa;
/*< YNV= YNV/ XA >*/
ynv /= xa;
/*< ZNV= ZNV/ XA >*/
znv /= xa;
/*< XST= SQRT( S1X* S1X+ S1Y* S1Y+ S1Z* S1Z) >*/
d__1 = s1x * s1x + s1y * s1y;
xst = sqrt(d__1 + s1z * s1z);
/*< T1X( MI)= S1X/ XST >*/
t1x[mi - 1] = s1x / xst;
/*< T1Y( MI)= S1Y/ XST >*/
t1y[mi - 1] = s1y / xst;
/*< T1Z( MI)= S1Z/ XST >*/
t1z[mi - 1] = s1z / xst;
/*< IF( NTP.GT.2) GOTO 4 >*/
if (ntp > 2) {
goto L4;
}
/*< X( MI)= X1+.5*( S1X+ S2X) >*/
data_1.x[mi - 1] = *x1 + (s1x + s2x) * .5;
/*< Y( MI)= Y1+.5*( S1Y+ S2Y) >*/
data_1.y[mi - 1] = *y1 + (s1y + s2y) * .5;
/*< Z( MI)= Z1+.5*( S1Z+ S2Z) >*/
data_1.z[mi - 1] = *z1 + (s1z + s2z) * .5;
/*< BI( MI)= XA >*/
data_1.bi[mi - 1] = xa;
/*< GOTO 6 >*/
goto L6;
/*< 4 IF( NTP.EQ.4) GOTO 5 >*/
L4:
if (ntp == 4) {
goto L5;
}
/*< X( MI)=( X1+ X2+ X3)/3. >*/
d__1 = *x1 + *x2;
data_1.x[mi - 1] = (d__1 + *x3) / 3.;
/*< Y( MI)=( Y1+ Y2+ Y3)/3. >*/
d__1 = *y1 + *y2;
data_1.y[mi - 1] = (d__1 + *y3) / 3.;
/*< Z( MI)=( Z1+ Z2+ Z3)/3. >*/
d__1 = *z1 + *z2;
data_1.z[mi - 1] = (d__1 + *z3) / 3.;
/*< BI( MI)=.5* XA >*/
data_1.bi[mi - 1] = xa * .5;
/*< GOTO 6 >*/
goto L6;
/*< 5 S1X= X3- X1 >*/
L5:
s1x = *x3 - *x1;
/*< S1Y= Y3- Y1 >*/
s1y = *y3 - *y1;
/*< S1Z= Z3- Z1 >*/
s1z = *z3 - *z1;
/*< S2X= X4- X1 >*/
s2x = *x4 - *x1;
/*< S2Y= Y4- Y1 >*/
s2y = *y4 - *y1;
/*< S2Z= Z4- Z1 >*/
s2z = *z4 - *z1;
/*< XN2= S1Y* S2Z- S1Z* S2Y >*/
xn2 = s1y * s2z - s1z * s2y;
/*< YN2= S1Z* S2X- S1X* S2Z >*/
yn2 = s1z * s2x - s1x * s2z;
/*< ZN2= S1X* S2Y- S1Y* S2X >*/
zn2 = s1x * s2y - s1y * s2x;
/*< XST= SQRT( XN2* XN2+ YN2* YN2+ ZN2* ZN2) >*/
d__1 = xn2 * xn2 + yn2 * yn2;
xst = sqrt(d__1 + zn2 * zn2);
/*< SALPN=1./(3.*( XA+ XST)) >*/
salpn = 1. / ((xa + xst) * 3.);
/*< X( MI)=( XA*( X1+ X2+ X3)+ XST*( X1+ X3+ X4))* SALPN >*/
d__1 = *x1 + *x2;
d__2 = *x1 + *x3;
data_1.x[mi - 1] = (xa * (d__1 + *x3) + xst * (d__2 + *x4)) * salpn;
/*< Y( MI)=( XA*( Y1+ Y2+ Y3)+ XST*( Y1+ Y3+ Y4))* SALPN >*/
d__1 = *y1 + *y2;
d__2 = *y1 + *y3;
data_1.y[mi - 1] = (xa * (d__1 + *y3) + xst * (d__2 + *y4)) * salpn;
/*< Z( MI)=( XA*( Z1+ Z2+ Z3)+ XST*( Z1+ Z3+ Z4))* SALPN >*/
d__1 = *z1 + *z2;
d__2 = *z1 + *z3;
data_1.z[mi - 1] = (xa * (d__1 + *z3) + xst * (d__2 + *z4)) * salpn;
/*< BI( MI)=.5*( XA+ XST) >*/
data_1.bi[mi - 1] = (xa + xst) * .5;
/*< S1X=( XNV* XN2+ YNV* YN2+ ZNV* ZN2)/ XST >*/
d__1 = xnv * xn2 + ynv * yn2;
s1x = (d__1 + znv * zn2) / xst;
/*< IF( S1X.GT.0.9998) GOTO 6 >*/
if (s1x > .9998) {
goto L6;
}
/*< WRITE( 6,14) >*/
s_wsfe(&io___1664);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 6 T2X( MI)= YNV* T1Z( MI)- ZNV* T1Y( MI) >*/
L6:
t2x[mi - 1] = ynv * t1z[mi - 1] - znv * t1y[mi - 1];
/*< T2Y( MI)= ZNV* T1X( MI)- XNV* T1Z( MI) >*/
t2y[mi - 1] = znv * t1x[mi - 1] - xnv * t1z[mi - 1];
/*< T2Z( MI)= XNV* T1Y( MI)- YNV* T1X( MI) >*/
t2z[mi - 1] = xnv * t1y[mi - 1] - ynv * t1x[mi - 1];
/*< SALP( MI)=1. >*/
angl_1.salp[mi - 1] = 1.;
/*< IF( NX.EQ.0) GOTO 8 >*/
if (*nx == 0) {
goto L8;
}
/*< M= M+ NX* NY-1 >*/
data_1.m = data_1.m + *nx * *ny - 1;
/*< XN2= X( MI)- S1X- S2X >*/
xn2 = data_1.x[mi - 1] - s1x - s2x;
/*< YN2= Y( MI)- S1Y- S2Y >*/
yn2 = data_1.y[mi - 1] - s1y - s2y;
/*< ZN2= Z( MI)- S1Z- S2Z >*/
zn2 = data_1.z[mi - 1] - s1z - s2z;
/*< XS= T1X( MI) >*/
xs = t1x[mi - 1];
/*< YS= T1Y( MI) >*/
ys = t1y[mi - 1];
/*< ZS= T1Z( MI) >*/
zs = t1z[mi - 1];
/*< XT= T2X( MI) >*/
xt = t2x[mi - 1];
/*< YT= T2Y( MI) >*/
yt = t2y[mi - 1];
/*< ZT= T2Z( MI) >*/
zt = t2z[mi - 1];
/*< MI= MI+1 >*/
++mi;
/*< DO 7 IY=1, NY >*/
i__1 = *ny;
for (iy = 1; iy <= i__1; ++iy) {
/*< XN2= XN2+ S2X >*/
xn2 += s2x;
/*< YN2= YN2+ S2Y >*/
yn2 += s2y;
/*< ZN2= ZN2+ S2Z >*/
zn2 += s2z;
/*< DO 7 IX=1, NX >*/
i__2 = *nx;
for (ix = 1; ix <= i__2; ++ix) {
/*< XST= IX >*/
xst = (doublereal) ix;
/*< MI= MI-1 >*/
--mi;
/*< X( MI)= XN2+ XST* S1X >*/
data_1.x[mi - 1] = xn2 + xst * s1x;
/*< Y( MI)= YN2+ XST* S1Y >*/
data_1.y[mi - 1] = yn2 + xst * s1y;
/*< Z( MI)= ZN2+ XST* S1Z >*/
data_1.z[mi - 1] = zn2 + xst * s1z;
/*< BI( MI)= XA >*/
data_1.bi[mi - 1] = xa;
/*< SALP( MI)=1. >*/
angl_1.salp[mi - 1] = 1.;
/*< T1X( MI)= XS >*/
t1x[mi - 1] = xs;
/*< T1Y( MI)= YS >*/
t1y[mi - 1] = ys;
/*< T1Z( MI)= ZS >*/
t1z[mi - 1] = zs;
/*< T2X( MI)= XT >*/
t2x[mi - 1] = xt;
/*< T2Y( MI)= YT >*/
t2y[mi - 1] = yt;
/*< 7 T2Z( MI)= ZT >*/
/* L7: */
t2z[mi - 1] = zt;
}
}
/*< 8 IPSYM=0 >*/
L8:
data_1.ipsym = 0;
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/* DIVIDE PATCH FOR WIRE CONNECTION */
/*< RETURN >*/
return 0;
/*< >*/
L_subph:
/*< IF( NY.GT.0) GOTO 10 >*/
if (*ny > 0) {
goto L10;
}
/*< IF( NX.EQ. M) GOTO 10 >*/
if (*nx == data_1.m) {
goto L10;
}
/*< NXP= NX+1 >*/
nxp = *nx + 1;
/*< IX= LD- M >*/
ix = data_1.ld - data_1.m;
/*< DO 9 IY= NXP, M >*/
i__2 = data_1.m;
for (iy = nxp; iy <= i__2; ++iy) {
/*< IX= IX+1 >*/
++ix;
/*< NYP= IX-3 >*/
nyp = ix - 3;
/*< X( NYP)= X( IX) >*/
data_1.x[nyp - 1] = data_1.x[ix - 1];
/*< Y( NYP)= Y( IX) >*/
data_1.y[nyp - 1] = data_1.y[ix - 1];
/*< Z( NYP)= Z( IX) >*/
data_1.z[nyp - 1] = data_1.z[ix - 1];
/*< BI( NYP)= BI( IX) >*/
data_1.bi[nyp - 1] = data_1.bi[ix - 1];
/*< SALP( NYP)= SALP( IX) >*/
angl_1.salp[nyp - 1] = angl_1.salp[ix - 1];
/*< T1X( NYP)= T1X( IX) >*/
t1x[nyp - 1] = t1x[ix - 1];
/*< T1Y( NYP)= T1Y( IX) >*/
t1y[nyp - 1] = t1y[ix - 1];
/*< T1Z( NYP)= T1Z( IX) >*/
t1z[nyp - 1] = t1z[ix - 1];
/*< T2X( NYP)= T2X( IX) >*/
t2x[nyp - 1] = t2x[ix - 1];
/*< T2Y( NYP)= T2Y( IX) >*/
t2y[nyp - 1] = t2y[ix - 1];
/*< 9 T2Z( NYP)= T2Z( IX) >*/
/* L9: */
t2z[nyp - 1] = t2z[ix - 1];
}
/*< 10 MI= LD+1- NX >*/
L10:
mi = data_1.ld + 1 - *nx;
/*< XS= X( MI) >*/
xs = data_1.x[mi - 1];
/*< YS= Y( MI) >*/
ys = data_1.y[mi - 1];
/*< ZS= Z( MI) >*/
zs = data_1.z[mi - 1];
/*< XA= BI( MI)*.25 >*/
xa = data_1.bi[mi - 1] * .25;
/*< XST= SQRT( XA)*.5 >*/
xst = sqrt(xa) * .5;
/*< S1X= T1X( MI) >*/
s1x = t1x[mi - 1];
/*< S1Y= T1Y( MI) >*/
s1y = t1y[mi - 1];
/*< S1Z= T1Z( MI) >*/
s1z = t1z[mi - 1];
/*< S2X= T2X( MI) >*/
s2x = t2x[mi - 1];
/*< S2Y= T2Y( MI) >*/
s2y = t2y[mi - 1];
/*< S2Z= T2Z( MI) >*/
s2z = t2z[mi - 1];
/*< SALN= SALP( MI) >*/
saln = angl_1.salp[mi - 1];
/*< XT= XST >*/
xt = xst;
/*< YT= XST >*/
yt = xst;
/*< IF( NY.GT.0) GOTO 11 >*/
if (*ny > 0) {
goto L11;
}
/*< MIA= MI >*/
mia = mi;
/*< GOTO 12 >*/
goto L12;
/*< 11 M= M+1 >*/
L11:
++data_1.m;
/*< MP= MP+1 >*/
++data_1.mp;
/*< MIA= LD+1- M >*/
mia = data_1.ld + 1 - data_1.m;
/*< 12 DO 13 IX=1,4 >*/
L12:
for (ix = 1; ix <= 4; ++ix) {
/*< X( MIA)= XS+ XT* S1X+ YT* S2X >*/
d__1 = xs + xt * s1x;
data_1.x[mia - 1] = d__1 + yt * s2x;
/*< Y( MIA)= YS+ XT* S1Y+ YT* S2Y >*/
d__1 = ys + xt * s1y;
data_1.y[mia - 1] = d__1 + yt * s2y;
/*< Z( MIA)= ZS+ XT* S1Z+ YT* S2Z >*/
d__1 = zs + xt * s1z;
data_1.z[mia - 1] = d__1 + yt * s2z;
/*< BI( MIA)= XA >*/
data_1.bi[mia - 1] = xa;
/*< T1X( MIA)= S1X >*/
t1x[mia - 1] = s1x;
/*< T1Y( MIA)= S1Y >*/
t1y[mia - 1] = s1y;
/*< T1Z( MIA)= S1Z >*/
t1z[mia - 1] = s1z;
/*< T2X( MIA)= S2X >*/
t2x[mia - 1] = s2x;
/*< T2Y( MIA)= S2Y >*/
t2y[mia - 1] = s2y;
/*< T2Z( MIA)= S2Z >*/
t2z[mia - 1] = s2z;
/*< SALP( MIA)= SALN >*/
angl_1.salp[mia - 1] = saln;
/*< IF( IX.EQ.2) YT=- YT >*/
if (ix == 2) {
yt = -yt;
}
/*< IF( IX.EQ.1.OR. IX.EQ.3) XT=- XT >*/
if (ix == 1 || ix == 3) {
xt = -xt;
}
/*< MIA= MIA-1 >*/
--mia;
/*< 13 CONTINUE >*/
/* L13: */
}
/*< M= M+3 >*/
data_1.m += 3;
/*< IF( NX.LE. MP) MP= MP+3 >*/
if (*nx <= data_1.mp) {
data_1.mp += 3;
}
/*< IF( NY.GT.0) Z( MI)=10000. >*/
if (*ny > 0) {
data_1.z[mi - 1] = 1e4;
}
/*< RETURN >*/
return 0;
/*< >*/
/*< END >*/
} /* patch_ */
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
/* Subroutine */ int patch_(nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4,
y4, z4)
integer *nx, *ny;
doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
{
return patch_0_(0, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
;
}
/* Subroutine */ int subph_(nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4,
y4, z4)
integer *nx, *ny;
doublereal *x1, *y1, *z1, *x2, *y2, *z2, *x3, *y3, *z3, *x4, *y4, *z4;
{
return patch_0_(1, nx, ny, x1, y1, z1, x2, y2, z2, x3, y3, z3, x4, y4, z4)
;
}
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE PCINT( XI, YI, ZI, CABI, SABI, SALPI, E) >*/
/* Subroutine */ int pcint_(xi, yi, zi, cabi, sabi, salpi, e)
doublereal *xi, *yi, *zi, *cabi, *sabi, *salpi;
doublecomplex *e;
{
/* Initialized data */
static doublereal tpi = 6.283185308;
static integer nint = 10;
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double sqrt();
/* Local variables */
static doublereal fcon, gcon, d;
extern /* Subroutine */ int unere_();
static doublecomplex e1, e2, e3, e4, e5, e6, e7, e8, e9;
static integer i1, i2;
static doublereal g1, g2, g3, s1, s2, g4, f2, f1, da, ds, xs, s2x, xxj,
xyj, xzj, xss, yss, zss;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
/* *** */
/* INTEGRATE OVER PATCHES AT WIRE CONNECTION POINT */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< DIMENSION E(9) >*/
/*< >*/
/*< DATA TPI/6.283185308D+0/, NINT/10/ >*/
/* Parameter adjustments */
--e;
/* Function Body */
/*< D= SQRT( S)*.5 >*/
d = sqrt(dataj_1.s) * .5;
/*< DS=4.* D/ DFLOAT( NINT) >*/
ds = d * 4. / (doublereal) nint;
/*< DA= DS* DS >*/
da = ds * ds;
/*< GCON=1./ S >*/
gcon = 1. / dataj_1.s;
/*< FCON=1./(2.* TPI* D) >*/
d__1 = tpi * 2.;
fcon = 1. / (d__1 * d);
/*< XXJ= XJ >*/
xxj = dataj_1.xj;
/*< XYJ= YJ >*/
xyj = dataj_1.yj;
/*< XZJ= ZJ >*/
xzj = dataj_1.zj;
/*< XS= S >*/
xs = dataj_1.s;
/*< S= DA >*/
dataj_1.s = da;
/*< S1= D+ DS*.5 >*/
s1 = d + ds * .5;
/*< XSS= XJ+ S1*( T1XJ+ T2XJ) >*/
xss = dataj_1.xj + s1 * (*t1xj + *t2xj);
/*< YSS= YJ+ S1*( T1YJ+ T2YJ) >*/
yss = dataj_1.yj + s1 * (*t1yj + *t2yj);
/*< ZSS= ZJ+ S1*( T1ZJ+ T2ZJ) >*/
zss = dataj_1.zj + s1 * (*t1zj + *t2zj);
/*< S1= S1+ D >*/
s1 += d;
/*< S2X= S1 >*/
s2x = s1;
/*< E1=(0.,0.) >*/
e1.r = 0., e1.i = 0.;
/*< E2=(0.,0.) >*/
e2.r = 0., e2.i = 0.;
/*< E3=(0.,0.) >*/
e3.r = 0., e3.i = 0.;
/*< E4=(0.,0.) >*/
e4.r = 0., e4.i = 0.;
/*< E5=(0.,0.) >*/
e5.r = 0., e5.i = 0.;
/*< E6=(0.,0.) >*/
e6.r = 0., e6.i = 0.;
/*< E7=(0.,0.) >*/
e7.r = 0., e7.i = 0.;
/*< E8=(0.,0.) >*/
e8.r = 0., e8.i = 0.;
/*< E9=(0.,0.) >*/
e9.r = 0., e9.i = 0.;
/*< DO 1 I1=1, NINT >*/
i__1 = nint;
for (i1 = 1; i1 <= i__1; ++i1) {
/*< S1= S1- DS >*/
s1 -= ds;
/*< S2= S2X >*/
s2 = s2x;
/*< XSS= XSS- DS* T1XJ >*/
xss -= ds * *t1xj;
/*< YSS= YSS- DS* T1YJ >*/
yss -= ds * *t1yj;
/*< ZSS= ZSS- DS* T1ZJ >*/
zss -= ds * *t1zj;
/*< XJ= XSS >*/
dataj_1.xj = xss;
/*< YJ= YSS >*/
dataj_1.yj = yss;
/*< ZJ= ZSS >*/
dataj_1.zj = zss;
/*< DO 1 I2=1, NINT >*/
i__2 = nint;
for (i2 = 1; i2 <= i__2; ++i2) {
/*< S2= S2- DS >*/
s2 -= ds;
/*< XJ= XJ- DS* T2XJ >*/
dataj_1.xj -= ds * *t2xj;
/*< YJ= YJ- DS* T2YJ >*/
dataj_1.yj -= ds * *t2yj;
/*< ZJ= ZJ- DS* T2ZJ >*/
dataj_1.zj -= ds * *t2zj;
/*< CALL UNERE( XI, YI, ZI) >*/
unere_(xi, yi, zi);
/*< EXK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
z__3.r = *cabi * dataj_1.exk.r, z__3.i = *cabi * dataj_1.exk.i;
z__4.r = *sabi * dataj_1.eyk.r, z__4.i = *sabi * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = *salpi * dataj_1.ezk.r, z__5.i = *salpi * dataj_1.ezk.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EXS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
z__3.r = *cabi * dataj_1.exs.r, z__3.i = *cabi * dataj_1.exs.i;
z__4.r = *sabi * dataj_1.eys.r, z__4.i = *sabi * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = *salpi * dataj_1.ezs.r, z__5.i = *salpi * dataj_1.ezs.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< G1=( D+ S1)*( D+ S2)* GCON >*/
d__1 = (d + s1) * (d + s2);
g1 = d__1 * gcon;
/*< G2=( D- S1)*( D+ S2)* GCON >*/
d__1 = (d - s1) * (d + s2);
g2 = d__1 * gcon;
/*< G3=( D- S1)*( D- S2)* GCON >*/
d__1 = (d - s1) * (d - s2);
g3 = d__1 * gcon;
/*< G4=( D+ S1)*( D- S2)* GCON >*/
d__1 = (d + s1) * (d - s2);
g4 = d__1 * gcon;
/*< F2=( S1* S1+ S2* S2)* TPI >*/
f2 = (s1 * s1 + s2 * s2) * tpi;
/*< F1= S1/ F2-( G1- G2- G3+ G4)* FCON >*/
f1 = s1 / f2 - (g1 - g2 - g3 + g4) * fcon;
/*< F2= S2/ F2-( G1+ G2- G3- G4)* FCON >*/
f2 = s2 / f2 - (g1 + g2 - g3 - g4) * fcon;
/*< E1= E1+ EXK* G1 >*/
z__2.r = g1 * dataj_1.exk.r, z__2.i = g1 * dataj_1.exk.i;
z__1.r = e1.r + z__2.r, z__1.i = e1.i + z__2.i;
e1.r = z__1.r, e1.i = z__1.i;
/*< E2= E2+ EXK* G2 >*/
z__2.r = g2 * dataj_1.exk.r, z__2.i = g2 * dataj_1.exk.i;
z__1.r = e2.r + z__2.r, z__1.i = e2.i + z__2.i;
e2.r = z__1.r, e2.i = z__1.i;
/*< E3= E3+ EXK* G3 >*/
z__2.r = g3 * dataj_1.exk.r, z__2.i = g3 * dataj_1.exk.i;
z__1.r = e3.r + z__2.r, z__1.i = e3.i + z__2.i;
e3.r = z__1.r, e3.i = z__1.i;
/*< E4= E4+ EXK* G4 >*/
z__2.r = g4 * dataj_1.exk.r, z__2.i = g4 * dataj_1.exk.i;
z__1.r = e4.r + z__2.r, z__1.i = e4.i + z__2.i;
e4.r = z__1.r, e4.i = z__1.i;
/*< E5= E5+ EXS* G1 >*/
z__2.r = g1 * dataj_1.exs.r, z__2.i = g1 * dataj_1.exs.i;
z__1.r = e5.r + z__2.r, z__1.i = e5.i + z__2.i;
e5.r = z__1.r, e5.i = z__1.i;
/*< E6= E6+ EXS* G2 >*/
z__2.r = g2 * dataj_1.exs.r, z__2.i = g2 * dataj_1.exs.i;
z__1.r = e6.r + z__2.r, z__1.i = e6.i + z__2.i;
e6.r = z__1.r, e6.i = z__1.i;
/*< E7= E7+ EXS* G3 >*/
z__2.r = g3 * dataj_1.exs.r, z__2.i = g3 * dataj_1.exs.i;
z__1.r = e7.r + z__2.r, z__1.i = e7.i + z__2.i;
e7.r = z__1.r, e7.i = z__1.i;
/*< E8= E8+ EXS* G4 >*/
z__2.r = g4 * dataj_1.exs.r, z__2.i = g4 * dataj_1.exs.i;
z__1.r = e8.r + z__2.r, z__1.i = e8.i + z__2.i;
e8.r = z__1.r, e8.i = z__1.i;
/*< 1 E9= E9+ EXK* F1+ EXS* F2 >*/
/* L1: */
z__3.r = f1 * dataj_1.exk.r, z__3.i = f1 * dataj_1.exk.i;
z__2.r = e9.r + z__3.r, z__2.i = e9.i + z__3.i;
z__4.r = f2 * dataj_1.exs.r, z__4.i = f2 * dataj_1.exs.i;
z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
e9.r = z__1.r, e9.i = z__1.i;
}
}
/*< E(1)= E1 >*/
e[1].r = e1.r, e[1].i = e1.i;
/*< E(2)= E2 >*/
e[2].r = e2.r, e[2].i = e2.i;
/*< E(3)= E3 >*/
e[3].r = e3.r, e[3].i = e3.i;
/*< E(4)= E4 >*/
e[4].r = e4.r, e[4].i = e4.i;
/*< E(5)= E5 >*/
e[5].r = e5.r, e[5].i = e5.i;
/*< E(6)= E6 >*/
e[6].r = e6.r, e[6].i = e6.i;
/*< E(7)= E7 >*/
e[7].r = e7.r, e[7].i = e7.i;
/*< E(8)= E8 >*/
e[8].r = e8.r, e[8].i = e8.i;
/*< E(9)= E9 >*/
e[9].r = e9.r, e[9].i = e9.i;
/*< XJ= XXJ >*/
dataj_1.xj = xxj;
/*< YJ= XYJ >*/
dataj_1.yj = xyj;
/*< ZJ= XZJ >*/
dataj_1.zj = xzj;
/*< S= XS >*/
dataj_1.s = xs;
/*< RETURN >*/
return 0;
/*< END >*/
} /* pcint_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int prnt_(in1, in2, in3, fl1, fl2, fl3, fl4, fl5, fl6, ia,
ichar)
integer *in1, *in2, *in3;
doublereal *fl1, *fl2, *fl3, *fl4, *fl5, *fl6;
integer *ia, *ichar;
{
/* Initialized data */
static char iform[6*8+1] = "(/3X, I5, 5X, A5, E13.4,13X, 3X, 5A\
4) ";
static struct {
char e_1[4];
integer e_2;
} equiv_1732 = { {' ', 'A', 'L', 'L'}, 0 };
#define hall (*(integer *)&equiv_1732)
/* System generated locals */
integer i__1, i__2, i__3;
doublereal d__1;
/* Builtin functions */
/* Subroutine */ int s_copy();
integer s_wsfe(), do_fio(), e_wsfe();
/* Local variables */
static char ivar[6*13];
static integer nflt, nint, i, j, k, l, i1;
static doublereal fl[6];
static integer in[3];
static doublereal flt[6];
static integer int_[3];
/* Fortran I/O blocks */
static cilist io___1729 = { 0, 6, 0, ivar, 0 };
/* *** */
/* PRNT SETS UP THE PRINT FORMATS FOR IMPEDANCE LOADING */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/* REAL IFORM, IVAR */
/*< CHARACTER*6 IFORM(8),IVAR(13) >*/
/*< DIMENSION IA(1),IN(3),INT(3),FL(6),FLT(6) >*/
/*< INTEGER HALL >*/
/* NUMBER OF CHARACTERS PER COMPUTER WORD IS NCPW */
/*< >*/
/* Parameter adjustments */
--ia;
/* Function Body */
/*< DATA HALL/4H ALL/ >*/
/*< IN(1)= IN1 >*/
in[0] = *in1;
/*< IN(2)= IN2 >*/
in[1] = *in2;
/*< IN(3)= IN3 >*/
in[2] = *in3;
/*< FL(1)= FL1 >*/
fl[0] = *fl1;
/*< FL(2)= FL2 >*/
fl[1] = *fl2;
/*< FL(3)= FL3 >*/
fl[2] = *fl3;
/*< FL(4)= FL4 >*/
fl[3] = *fl4;
/*< FL(5)= FL5 >*/
fl[4] = *fl5;
/* INTEGER FORMAT */
/*< FL(6)= FL6 >*/
fl[5] = *fl6;
/*< NINT=0 >*/
nint = 0;
/*< IVAR(1)= IFORM(1) >*/
s_copy(ivar, iform, 6L, 6L);
/*< K=1 >*/
k = 1;
/*< I1=1 >*/
i1 = 1;
/*< IF(.NOT.( IN1.EQ.0.AND. IN2.EQ.0.AND. IN3.EQ.0)) GOTO 1 >*/
if (! (*in1 == 0 && *in2 == 0 && *in3 == 0)) {
goto L1;
}
/*< INT(1)= HALL >*/
int_[0] = hall;
/*< NINT=1 >*/
nint = 1;
/*< I1=2 >*/
i1 = 2;
/*< K= K+1 >*/
++k;
/*< IVAR( K)= IFORM(4) >*/
s_copy(ivar + (k - 1) * 6, iform + 18, 6L, 6L);
/*< 1 DO 3 I= I1,3 >*/
L1:
for (i = i1; i <= 3; ++i) {
/*< K= K+1 >*/
++k;
/*< IF( IN( I).EQ.0) GOTO 2 >*/
if (in[i - 1] == 0) {
goto L2;
}
/*< NINT= NINT+1 >*/
++nint;
/*< INT( NINT)= IN( I) >*/
int_[nint - 1] = in[i - 1];
/*< IVAR( K)= IFORM(2) >*/
s_copy(ivar + (k - 1) * 6, iform + 6, 6L, 6L);
/*< GOTO 3 >*/
goto L3;
/*< 2 IVAR( K)= IFORM(3) >*/
L2:
s_copy(ivar + (k - 1) * 6, iform + 12, 6L, 6L);
/*< 3 CONTINUE >*/
L3:
;
}
/*< K= K+1 >*/
++k;
/* DFLOATING POINT FORMAT */
/*< IVAR( K)= IFORM(7) >*/
s_copy(ivar + (k - 1) * 6, iform + 36, 6L, 6L);
/*< NFLT=0 >*/
nflt = 0;
/*< DO 5 I=1,6 >*/
for (i = 1; i <= 6; ++i) {
/*< K= K+1 >*/
++k;
/*< IF( ABS( FL( I)).LT.1.D-20) GOTO 4 >*/
if ((d__1 = fl[i - 1], abs(d__1)) < 1e-20) {
goto L4;
}
/*< NFLT= NFLT+1 >*/
++nflt;
/*< FLT( NFLT)= FL( I) >*/
flt[nflt - 1] = fl[i - 1];
/*< IVAR( K)= IFORM(5) >*/
s_copy(ivar + (k - 1) * 6, iform + 24, 6L, 6L);
/*< GOTO 5 >*/
goto L5;
/*< 4 IVAR( K)= IFORM(6) >*/
L4:
s_copy(ivar + (k - 1) * 6, iform + 30, 6L, 6L);
/*< 5 CONTINUE >*/
L5:
;
}
/*< K= K+1 >*/
++k;
/*< IVAR( K)= IFORM(7) >*/
s_copy(ivar + (k - 1) * 6, iform + 36, 6L, 6L);
/*< K= K+1 >*/
++k;
/*< IVAR( K)= IFORM(8) >*/
s_copy(ivar + (k - 1) * 6, iform + 42, 6L, 6L);
/*< >*/
s_wsfe(&io___1729);
i__1 = nint;
for (i = 1; i <= i__1; ++i) {
do_fio(&c__1, (char *)&int_[i - 1], (ftnlen)sizeof(integer));
}
i__2 = nflt;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&flt[j - 1], (ftnlen)sizeof(doublereal));
}
i__3 = *ichar;
for (l = 1; l <= i__3; ++l) {
do_fio(&c__1, (char *)&ia[l], (ftnlen)sizeof(integer));
}
e_wsfe();
/*< RETURN >*/
return 0;
/*< END >*/
} /* prnt_ */
#undef hall
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE QDSRC( IS, V, E) >*/
/* Subroutine */ int qdsrc_(is, v, e)
integer *is;
doublecomplex *v, *e;
{
/* Initialized data */
static doublereal tp = 6.283185308;
static struct {
doublereal e_1[3];
} equiv_0 = { 0., -.01666666667, 0. };
/* System generated locals */
integer i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8;
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8;
/* Builtin functions */
double log(), cos(), sin();
/* Local variables */
extern /* Subroutine */ int efld_();
static doublereal sabi;
#define ccjx ((doublereal *)&equiv_0)
static doublecomplex curd;
static integer i, j;
extern /* Subroutine */ int hsfld_();
static doublereal salpi;
static integer i1;
static doublereal ai;
static integer ij;
static doublereal xi;
static integer jx;
static doublereal yi, zi, tx, ty, tz;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
#define cab ((doublereal *)&data_1 + 3000)
#define ccj ((doublecomplex *)&equiv_0)
#define sab ((doublereal *)&data_1 + 3600)
static doublecomplex etc;
extern /* Subroutine */ int tbf_();
static doublecomplex etk, ets;
static integer ipr;
static doublereal cabi;
/* *** */
/* FILL INCIDENT FIELD ARRAY FOR CHARGE DISCONTINUITY VOLTAGE SOURCE
*/
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< COMMON /ZLOAD/ ZARRAY( NM), NLOAD, NLODF >*/
/*< DIMENSION CCJX(2), E(1), CAB(1), SAB(1) >*/
/*< DIMENSION T1X(1), T1Y(1), T1Z(1), T2X(1), T2Y(1), T2Z(1) >*/
/*< EQUIVALENCE(CCJ,CCJX),(CAB,ALP),(SAB,BET) >*/
/*< >*/
/*< DATA TP/6.283185308D+0/, CCJX/0.,-.01666666667D+0/ >*/
/* Parameter adjustments */
--e;
/* Function Body */
/*< I= ICON1( IS) >*/
i = data_1.icon1[*is - 1];
/*< ICON1( IS)=0 >*/
data_1.icon1[*is - 1] = 0;
/*< CALL TBF( IS,0) >*/
tbf_(is, &c__0);
/*< ICON1( IS)= I >*/
data_1.icon1[*is - 1] = i;
/*< S= SI( IS)*.5 >*/
dataj_1.s = data_1.si[*is - 1] * .5;
/*< >*/
z__2.r = ccj->r * v->r - ccj->i * v->i, z__2.i = ccj->r * v->i + ccj->i *
v->r;
d__2 = (log(dataj_1.s * 2. / data_1.bi[*is - 1]) - 1.) * (segj_1.bx[
segj_1.jsno - 1] * cos(tp * dataj_1.s) + segj_1.cx[segj_1.jsno -
1] * sin(tp * dataj_1.s));
d__1 = d__2 * data_1.wlam;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
curd.r = z__1.r, curd.i = z__1.i;
/*< NQDS= NQDS+1 >*/
++vsorc_1.nqds;
/*< VQDS( NQDS)= V >*/
i__1 = vsorc_1.nqds - 1;
vsorc_1.vqds[i__1].r = v->r, vsorc_1.vqds[i__1].i = v->i;
/*< IQDS( NQDS)= IS >*/
vsorc_1.iqds[vsorc_1.nqds - 1] = *is;
/*< DO 20 JX=1, JSNO >*/
i__1 = segj_1.jsno;
for (jx = 1; jx <= i__1; ++jx) {
/*< J= JCO( JX) >*/
j = segj_1.jco[jx - 1];
/*< S= SI( J) >*/
dataj_1.s = data_1.si[j - 1];
/*< B= BI( J) >*/
dataj_1.b = data_1.bi[j - 1];
/*< XJ= X( J) >*/
dataj_1.xj = data_1.x[j - 1];
/*< YJ= Y( J) >*/
dataj_1.yj = data_1.y[j - 1];
/*< ZJ= Z( J) >*/
dataj_1.zj = data_1.z[j - 1];
/*< CABJ= CAB( J) >*/
dataj_1.cabj = cab[j - 1];
/*< SABJ= SAB( J) >*/
dataj_1.sabj = sab[j - 1];
/*< SALPJ= SALP( J) >*/
dataj_1.salpj = angl_1.salp[j - 1];
/*< IF( IEXK.EQ.0) GOTO 16 >*/
if (dataj_1.iexk == 0) {
goto L16;
}
/*< IPR= ICON1( J) >*/
ipr = data_1.icon1[j - 1];
/*< IF( IPR) 1,6,2 >*/
if (ipr < 0) {
goto L1;
} else if (ipr == 0) {
goto L6;
} else {
goto L2;
}
/*< 1 IPR=- IPR >*/
L1:
ipr = -ipr;
/*< IF(- ICON1( IPR).NE. J) GOTO 7 >*/
if (-data_1.icon1[ipr - 1] != j) {
goto L7;
}
/*< GOTO 4 >*/
goto L4;
/*< 2 IF( IPR.NE. J) GOTO 3 >*/
L2:
if (ipr != j) {
goto L3;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 7 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8)
{
goto L7;
}
/*< GOTO 5 >*/
goto L5;
/*< 3 IF( ICON2( IPR).NE. J) GOTO 7 >*/
L3:
if (data_1.icon2[ipr - 1] != j) {
goto L7;
}
/*< 4 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L4:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 7 >*/
if (xi < .999999) {
goto L7;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 7 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L7;
}
/*< 5 IND1=0 >*/
L5:
dataj_1.ind1 = 0;
/*< GOTO 8 >*/
goto L8;
/*< 6 IND1=1 >*/
L6:
dataj_1.ind1 = 1;
/*< GOTO 8 >*/
goto L8;
/*< 7 IND1=2 >*/
L7:
dataj_1.ind1 = 2;
/*< 8 IPR= ICON2( J) >*/
L8:
ipr = data_1.icon2[j - 1];
/*< IF( IPR) 9,14,10 >*/
if (ipr < 0) {
goto L9;
} else if (ipr == 0) {
goto L14;
} else {
goto L10;
}
/*< 9 IPR=- IPR >*/
L9:
ipr = -ipr;
/*< IF(- ICON2( IPR).NE. J) GOTO 15 >*/
if (-data_1.icon2[ipr - 1] != j) {
goto L15;
}
/*< GOTO 12 >*/
goto L12;
/*< 10 IF( IPR.NE. J) GOTO 11 >*/
L10:
if (ipr != j) {
goto L11;
}
/*< IF( CABJ* CABJ+ SABJ* SABJ.GT.1.D-8) GOTO 15 >*/
if (dataj_1.cabj * dataj_1.cabj + dataj_1.sabj * dataj_1.sabj > 1e-8)
{
goto L15;
}
/*< GOTO 13 >*/
goto L13;
/*< 11 IF( ICON1( IPR).NE. J) GOTO 15 >*/
L11:
if (data_1.icon1[ipr - 1] != j) {
goto L15;
}
/*< 12 XI= ABS( CABJ* CAB( IPR)+ SABJ* SAB( IPR)+ SALPJ* SALP( IPR)) >*/
L12:
d__2 = dataj_1.cabj * cab[ipr - 1] + dataj_1.sabj * sab[ipr - 1];
xi = (d__1 = d__2 + dataj_1.salpj * angl_1.salp[ipr - 1], abs(d__1));
/*< IF( XI.LT.0.999999D+0) GOTO 15 >*/
if (xi < .999999) {
goto L15;
}
/*< IF( ABS( BI( IPR)/ B-1.).GT.1.D-6) GOTO 15 >*/
if ((d__1 = data_1.bi[ipr - 1] / dataj_1.b - 1., abs(d__1)) > 1e-6) {
goto L15;
}
/*< 13 IND2=0 >*/
L13:
dataj_1.ind2 = 0;
/*< GOTO 16 >*/
goto L16;
/*< 14 IND2=1 >*/
L14:
dataj_1.ind2 = 1;
/*< GOTO 16 >*/
goto L16;
/*< 15 IND2=2 >*/
L15:
dataj_1.ind2 = 2;
/*< 16 CONTINUE >*/
L16:
/*< DO 17 I=1, N >*/
i__2 = data_1.n;
for (i = 1; i <= i__2; ++i) {
/*< IJ= I- J >*/
ij = i - j;
/*< XI= X( I) >*/
xi = data_1.x[i - 1];
/*< YI= Y( I) >*/
yi = data_1.y[i - 1];
/*< ZI= Z( I) >*/
zi = data_1.z[i - 1];
/*< AI= BI( I) >*/
ai = data_1.bi[i - 1];
/*< CALL EFLD( XI, YI, ZI, AI, IJ) >*/
efld_(&xi, &yi, &zi, &ai, &ij);
/*< CABI= CAB( I) >*/
cabi = cab[i - 1];
/*< SABI= SAB( I) >*/
sabi = sab[i - 1];
/*< SALPI= SALP( I) >*/
salpi = angl_1.salp[i - 1];
/*< ETK= EXK* CABI+ EYK* SABI+ EZK* SALPI >*/
z__3.r = cabi * dataj_1.exk.r, z__3.i = cabi * dataj_1.exk.i;
z__4.r = sabi * dataj_1.eyk.r, z__4.i = sabi * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezk.r, z__5.i = salpi * dataj_1.ezk.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etk.r = z__1.r, etk.i = z__1.i;
/*< ETS= EXS* CABI+ EYS* SABI+ EZS* SALPI >*/
z__3.r = cabi * dataj_1.exs.r, z__3.i = cabi * dataj_1.exs.i;
z__4.r = sabi * dataj_1.eys.r, z__4.i = sabi * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezs.r, z__5.i = salpi * dataj_1.ezs.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ets.r = z__1.r, ets.i = z__1.i;
/*< ETC= EXC* CABI+ EYC* SABI+ EZC* SALPI >*/
z__3.r = cabi * dataj_1.exc.r, z__3.i = cabi * dataj_1.exc.i;
z__4.r = sabi * dataj_1.eyc.r, z__4.i = sabi * dataj_1.eyc.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = salpi * dataj_1.ezc.r, z__5.i = salpi * dataj_1.ezc.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etc.r = z__1.r, etc.i = z__1.i;
/*< 17 E( I)= E( I)-( ETK* AX( JX)+ ETS* BX( JX)+ ETC* CX( JX))* CURD >*/
/* L17: */
i__3 = i;
i__4 = i;
i__5 = jx - 1;
z__5.r = segj_1.ax[i__5] * etk.r, z__5.i = segj_1.ax[i__5] *
etk.i;
i__6 = jx - 1;
z__6.r = segj_1.bx[i__6] * ets.r, z__6.i = segj_1.bx[i__6] *
ets.i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
i__7 = jx - 1;
z__7.r = segj_1.cx[i__7] * etc.r, z__7.i = segj_1.cx[i__7] *
etc.i;
z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i;
z__2.r = z__3.r * curd.r - z__3.i * curd.i, z__2.i = z__3.r *
curd.i + z__3.i * curd.r;
z__1.r = e[i__4].r - z__2.r, z__1.i = e[i__4].i - z__2.i;
e[i__3].r = z__1.r, e[i__3].i = z__1.i;
}
/*< IF( M.EQ.0) GOTO 19 >*/
if (data_1.m == 0) {
goto L19;
}
/*< IJ= LD+1 >*/
ij = data_1.ld + 1;
/*< I1= N >*/
i1 = data_1.n;
/*< DO 18 I=1, M >*/
i__3 = data_1.m;
for (i = 1; i <= i__3; ++i) {
/*< IJ= IJ-1 >*/
--ij;
/*< XI= X( IJ) >*/
xi = data_1.x[ij - 1];
/*< YI= Y( IJ) >*/
yi = data_1.y[ij - 1];
/*< ZI= Z( IJ) >*/
zi = data_1.z[ij - 1];
/*< CALL HSFLD( XI, YI, ZI,0.) >*/
hsfld_(&xi, &yi, &zi, &c_b594);
/*< I1= I1+1 >*/
++i1;
/*< TX= T2X( IJ) >*/
tx = t2x[ij - 1];
/*< TY= T2Y( IJ) >*/
ty = t2y[ij - 1];
/*< TZ= T2Z( IJ) >*/
tz = t2z[ij - 1];
/*< ETK= EXK* TX+ EYK* TY+ EZK* TZ >*/
z__3.r = tx * dataj_1.exk.r, z__3.i = tx * dataj_1.exk.i;
z__4.r = ty * dataj_1.eyk.r, z__4.i = ty * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezk.r, z__5.i = tz * dataj_1.ezk.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etk.r = z__1.r, etk.i = z__1.i;
/*< ETS= EXS* TX+ EYS* TY+ EZS* TZ >*/
z__3.r = tx * dataj_1.exs.r, z__3.i = tx * dataj_1.exs.i;
z__4.r = ty * dataj_1.eys.r, z__4.i = ty * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezs.r, z__5.i = tz * dataj_1.ezs.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ets.r = z__1.r, ets.i = z__1.i;
/*< ETC= EXC* TX+ EYC* TY+ EZC* TZ >*/
z__3.r = tx * dataj_1.exc.r, z__3.i = tx * dataj_1.exc.i;
z__4.r = ty * dataj_1.eyc.r, z__4.i = ty * dataj_1.eyc.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezc.r, z__5.i = tz * dataj_1.ezc.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etc.r = z__1.r, etc.i = z__1.i;
/*< >*/
i__4 = i1;
i__5 = i1;
i__6 = jx - 1;
z__6.r = segj_1.ax[i__6] * etk.r, z__6.i = segj_1.ax[i__6] *
etk.i;
i__7 = jx - 1;
z__7.r = segj_1.bx[i__7] * ets.r, z__7.i = segj_1.bx[i__7] *
ets.i;
z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
i__2 = jx - 1;
z__8.r = segj_1.cx[i__2] * etc.r, z__8.i = segj_1.cx[i__2] *
etc.i;
z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
z__3.r = z__4.r * curd.r - z__4.i * curd.i, z__3.i = z__4.r *
curd.i + z__4.i * curd.r;
i__8 = ij - 1;
z__2.r = angl_1.salp[i__8] * z__3.r, z__2.i = angl_1.salp[i__8] *
z__3.i;
z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
e[i__4].r = z__1.r, e[i__4].i = z__1.i;
/*< I1= I1+1 >*/
++i1;
/*< TX= T1X( IJ) >*/
tx = t1x[ij - 1];
/*< TY= T1Y( IJ) >*/
ty = t1y[ij - 1];
/*< TZ= T1Z( IJ) >*/
tz = t1z[ij - 1];
/*< ETK= EXK* TX+ EYK* TY+ EZK* TZ >*/
z__3.r = tx * dataj_1.exk.r, z__3.i = tx * dataj_1.exk.i;
z__4.r = ty * dataj_1.eyk.r, z__4.i = ty * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezk.r, z__5.i = tz * dataj_1.ezk.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etk.r = z__1.r, etk.i = z__1.i;
/*< ETS= EXS* TX+ EYS* TY+ EZS* TZ >*/
z__3.r = tx * dataj_1.exs.r, z__3.i = tx * dataj_1.exs.i;
z__4.r = ty * dataj_1.eys.r, z__4.i = ty * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezs.r, z__5.i = tz * dataj_1.ezs.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
ets.r = z__1.r, ets.i = z__1.i;
/*< ETC= EXC* TX+ EYC* TY+ EZC* TZ >*/
z__3.r = tx * dataj_1.exc.r, z__3.i = tx * dataj_1.exc.i;
z__4.r = ty * dataj_1.eyc.r, z__4.i = ty * dataj_1.eyc.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = tz * dataj_1.ezc.r, z__5.i = tz * dataj_1.ezc.i;
z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
etc.r = z__1.r, etc.i = z__1.i;
/*< >*/
/* L18: */
i__4 = i1;
i__5 = i1;
i__6 = jx - 1;
z__6.r = segj_1.ax[i__6] * etk.r, z__6.i = segj_1.ax[i__6] *
etk.i;
i__7 = jx - 1;
z__7.r = segj_1.bx[i__7] * ets.r, z__7.i = segj_1.bx[i__7] *
ets.i;
z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
i__2 = jx - 1;
z__8.r = segj_1.cx[i__2] * etc.r, z__8.i = segj_1.cx[i__2] *
etc.i;
z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i;
z__3.r = z__4.r * curd.r - z__4.i * curd.i, z__3.i = z__4.r *
curd.i + z__4.i * curd.r;
i__8 = ij - 1;
z__2.r = angl_1.salp[i__8] * z__3.r, z__2.i = angl_1.salp[i__8] *
z__3.i;
z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
e[i__4].r = z__1.r, e[i__4].i = z__1.i;
}
/*< >*/
L19:
if (zload_1.nload > 0 || zload_1.nlodf > 0) {
i__4 = j;
i__5 = j;
i__6 = j - 1;
z__3.r = zload_1.zarray[i__6].r * curd.r - zload_1.zarray[i__6].i
* curd.i, z__3.i = zload_1.zarray[i__6].r * curd.i +
zload_1.zarray[i__6].i * curd.r;
d__1 = segj_1.ax[jx - 1] + segj_1.cx[jx - 1];
z__2.r = d__1 * z__3.r, z__2.i = d__1 * z__3.i;
z__1.r = e[i__5].r + z__2.r, z__1.i = e[i__5].i + z__2.i;
e[i__4].r = z__1.r, e[i__4].i = z__1.i;
}
/*< 20 CONTINUE >*/
/* L20: */
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* qdsrc_ */
#undef sab
#undef ccj
#undef cab
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef ccjx
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE RDPAT >*/
/* Subroutine */ int rdpat_()
{
/* Initialized data */
static char hblk[6+1] = " ";
static char hpol[6*3+1] = "LINEARRIGHT LEFT ";
static char hcir[6+1] = "CIRCLE";
static struct {
char e_1[32];
doublereal e_2;
} equiv_1852 = { {' ', ' ', ' ', ' ', '-', ' ', ' ', ' ', 'P', 'O',
'W', 'E', 'R', ' ', ' ', ' ', '-', ' ', 'D', 'I', 'R', 'E',
' ', ' ', 'C', 'T', 'I', 'V', 'E', ' ', ' ', ' '}, 0. };
#define igtp ((doublereal *)&equiv_1852)
static struct {
char e_1[32];
doublereal e_2;
} equiv_1853 = { {' ', 'M', 'A', 'J', 'O', 'R', ' ', ' ', ' ', 'M',
'I', 'N', 'O', 'R', ' ', ' ', ' ', 'V', 'E', 'R', 'T', '.',
' ', ' ', ' ', 'H', 'O', 'R', '.', ' ', ' ', ' '}, 0. };
#define igax ((doublereal *)&equiv_1853)
static struct {
char e_1[80];
doublereal e_2;
} equiv_1854 = { {' ', 'M', 'A', 'J', 'O', 'R', ' ', ' ', ' ', 'A',
'X', 'I', 'S', ' ', ' ', ' ', ' ', 'M', 'I', 'N', 'O', 'R',
' ', ' ', ' ', 'A', 'X', 'I', 'S', ' ', ' ', ' ', ' ', ' ',
' ', 'V', 'E', 'R', ' ', ' ', 'T', 'I', 'C', 'A', 'L', ' ',
' ', ' ', ' ', 'H', 'O', 'R', 'I', 'Z', ' ', ' ', 'O', 'N',
'T', 'A', 'L', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ',
' ', ' ', 'T', 'O', 'T', 'A', 'L', ' ', ' ', ' '}, 0. };
#define igntp ((doublereal *)&equiv_1854)
static doublereal pi = 3.141592654;
static doublereal ta = .01745329252;
static doublereal td = 57.29577951;
static integer normax = 800;
/* Format strings */
static char fmt_35[] = "(///,31x,\002- - - FAR FIELD GROUND PARAMETERS -\
- -\002,//)";
static char fmt_36[] = "(40x,\002RADIAL WIRE GROUND SCREEN\002,/,40x,i5\
,\002 WIRES\002,/,40x,\002WIRE LENGTH=\002,f8.2,\002 METERS\002,/,40x,\002WI\
RE RADIUS=\002,1p,e10.3,\002 METERS\002)";
static char fmt_37[] = "(40x,a6,\002 CLIFF\002,/,40x,\002EDGE DISTANCE\
=\002,f9.2,\002 METERS\002,/,40x,\002HEIGHT=\002,f8.2,\002 METERS\002,/,40x\
,\002SECOND MEDIUM -\002,/,40x,\002RELA\002,\002TIVE DIELECTRIC CONST.=\002,\
f7.3,/,40x,\002CONDUCTIVITY=\002,1p,e10.3,\002 MHOS\002)";
static char fmt_41[] = "(///,28x,\002 - - - RADIATED FIELDS NEAR GROUND \
- - -\002,//,8x,\002- - - LOCATION - - -\002,10x,\002- - E(THETA) - -\002,8x,\
\002- - E(PHI) -\002\002 -\002,8x,\002- - E(RADIAL) - -\002,/,7x,\002RHO\002\
,6x,\002PHI\002,9x,\002Z\002,12x,\002MAG\002,6x,\002PHASE\002,9x,\002MAG\002\
,6x,\002PHASE\002,9x,\002MAG\002,6x,\002PHASE\002,/,5x,\002METERS\002,3x,\
\002DEGREES\002,4x,\002METERS\002,8x,\002VOLTS/M\002,3x,\002DEGREES\002,6x\
,\002VOLTS/M\002,3x,\002DEGREES\002,6x,\002VOLTS/M\002,3x,\002DEGREES\002,/)";
static char fmt_38[] = "(///,48x,\002- - - RADIATION PATTERNS - - -\002)";
static char fmt_39[] = "(54x,\002RANGE=\002,1p,e13.6,\002 METERS\002,/,5\
4x,\002EXP(-JKR)/R=\002,e12.5,\002 AT PHASE\002,0p,f7.2,\002 DEGREES\002,/)";
static char fmt_40[] = "(/,2x,\002- - ANGLES - -\002,7x,2a6,\002GAINS \
-\002,7x,\002- - - POLARI\002,\002ZATION - - -\002,4x,\002- - - E(THETA) - -\
-\002,4x,\002- - - E(PHI) - -\002,\002 -\002,/,2x,\002THETA\002,5x,\002PH\
I\002,7x,a6,2x,a6,3x,\002TOTAL\002,6x,\002AXIAL\002,5x,\002TILT\002,3x,\002S\
ENSE\002,2(5x,\002MAGNITUDE\002,4x,\002PHASE\002),/,2(1x,\002DEGREES\002,1x)\
,3(6x,\002DB\002),8x,\002RATIO\002,5x,\002DEG.\002,8x,2(6x,\002VOLTS/M\002,4\
x,\002DEGRE\002,\002ES\002))";
static char fmt_42[] = "(1x,f7.2,f9.2,3x,3f8.2,f11.5,f9.2,2x,a6,2(1p,e15\
.5,0p,f9.2))";
static char fmt_43[] = "(3x,f9.2,2x,f7.2,2x,f9.2,1x,3(3x,1p,e11.4,2x,0p,\
f7.2))";
static char fmt_44[] = "(//,3x,\002AVERAGE POWER GAIN=\002,1p,e12.5,7x\
,\002SOLID ANGLE U\002,\002SED IN AVERAGING=(\002,0p,f7.4,\002)*PI STERADIAN\
S.\002,//)";
static char fmt_45[] = "(//,37x,\002- - - - NORMALIZED GAIN - - - -\002,\
//,37x,2a6,\002GAI\002,\002N\002,/,38x,\002NORMALIZATION FACTOR =\002,f9.2\
,\002 DB\002,//,3(4x,\002- - ANGLES' - -\002,6x,\002GAIN\002,7x),/,3(4x,\002\
THETA\002,5x,\002PHI\002,8x,\002DB\002,8x),/,3(3x,\002DEGREES\002,2x,\002DEG\
REES\002,16x))";
static char fmt_46[] = "(3(1x,2f9.2,1x,f9.2,6x))";
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3;
/* Builtin functions */
integer s_wsfe(), e_wsfe(), do_fio();
/* Subroutine */ int s_copy();
void z_div(), z_sqrt();
double d_int(), z_abs();
void d_cnjg();
double sqrt(), cos(), sin();
integer s_wsle(), do_lio(), e_wsle();
/* Local variables */
extern doublereal cang_();
extern /* Subroutine */ int ffld_(), gfld_();
static doublereal erda, epha, prad, gcon, gcop, gmax, exra, pint, exrm,
thet, erdm, ethm, etha, ephm, dfaz, gnmj, gnmn, gtot, dfaz2,
ephm2;
extern doublereal atgn2_();
static doublereal ethm2;
static integer itmp1, itmp2, itmp3, itmp4, i, j;
static char hclif[6];
static doublereal cdfaz, tilta, axrat;
static char isens[6];
static doublereal emajr2, eminr2, da, tstor1, tstor2, stilta;
extern doublereal db10_();
static doublereal pha;
static doublecomplex erd, eph, eth;
static doublereal phi;
static integer kph, kth;
static doublereal tha, gnv, gnh, tmp1, tmp2, tmp3, tmp4, tmp5, tmp6;
/* Fortran I/O blocks */
static cilist io___1774 = { 0, 6, 0, fmt_35, 0 };
static cilist io___1775 = { 0, 6, 0, fmt_36, 0 };
static cilist io___1777 = { 0, 6, 0, fmt_37, 0 };
static cilist io___1778 = { 0, 6, 0, fmt_41, 0 };
static cilist io___1783 = { 0, 6, 0, fmt_38, 0 };
static cilist io___1786 = { 0, 6, 0, fmt_39, 0 };
static cilist io___1787 = { 0, 6, 0, fmt_40, 0 };
static cilist io___1833 = { 0, 6, 0, fmt_42, 0 };
static cilist io___1834 = { 0, 8, 0, 0, 0 };
static cilist io___1835 = { 0, 8, 0, 0, 0 };
static cilist io___1836 = { 0, 8, 0, 0, 0 };
static cilist io___1837 = { 0, 8, 0, 0, 0 };
static cilist io___1838 = { 0, 8, 0, 0, 0 };
static cilist io___1839 = { 0, 8, 0, 0, 0 };
static cilist io___1840 = { 0, 8, 0, 0, 0 };
static cilist io___1841 = { 0, 8, 0, 0, 0 };
static cilist io___1842 = { 0, 8, 0, 0, 0 };
static cilist io___1843 = { 0, 8, 0, 0, 0 };
static cilist io___1844 = { 0, 6, 0, fmt_43, 0 };
static cilist io___1845 = { 0, 6, 0, fmt_44, 0 };
static cilist io___1846 = { 0, 6, 0, fmt_45, 0 };
static cilist io___1849 = { 0, 6, 0, fmt_46, 0 };
static cilist io___1850 = { 0, 6, 0, fmt_46, 0 };
static cilist io___1851 = { 0, 6, 0, fmt_46, 0 };
/* *** */
/* COMPUTE RADIATION PATTERN, GAIN, NORMALIZED GAIN */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/* INTEGER HPOL,HBLK,HCIR,HCLIF */
/*< REAL IGNTP, IGAX, IGTP, COM >*/
/*< COMPLEX ETH, EPH, ERD, ZRATI, ZRATI2, T1, FRATI >*/
/*< >*/
/*< COMMON /SAVE/COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ,IP(N2M),KCOM >*/
/*< >*/
/*< >*/
/* *** */
/*< COMMON /SCRATM/ GAIN(N2M) >*/
/* *** */
/*< COMMON /PLOT/ IPLP1, IPLP2, IPLP3, IPLP4 >*/
/*< DIMENSION IGTP(4), IGAX(4), IGNTP(10) >*/
/*< CHARACTER*6 HPOL(3),HCLIF,ISENS,HCIR,HBLK >*/
/*< DATA HBLK/6H / >*/
/*< DATA HPOL/6HLINEAR,5HRIGHT,4HLEFT/, HCIR/6HCIRCLE/ >*/
/*< DATA IGTP/6H - ,6HPOWER ,6H- DIRE,6HCTIVE / >*/
/*< DATA IGAX/6H MAJOR,6H MINOR,6H VERT.,6H HOR. / >*/
/*< >*/
/*< DATA PI, TA, TD/3.141592654D+0,1.745329252D-02,57.29577951D+0/ >*/
/*< DATA NORMAX/800/ >*/
/*< IF( IFAR.LT.2) GOTO 2 >*/
if (gnd_1.ifar < 2) {
goto L2;
}
/*< WRITE( 6,35) >*/
s_wsfe(&io___1774);
e_wsfe();
/*< IF( IFAR.LE.3) GOTO 1 >*/
if (gnd_1.ifar <= 3) {
goto L1;
}
/*< WRITE( 6,36) NRADL, SCRWLT, SCRWRT >*/
s_wsfe(&io___1775);
do_fio(&c__1, (char *)&gnd_1.nradl, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&save_1.scrwlt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&save_1.scrwrt, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IFAR.EQ.4) GOTO 2 >*/
if (gnd_1.ifar == 4) {
goto L2;
}
/*< 1 IF( IFAR.EQ.2.OR. IFAR.EQ.5) HCLIF= HPOL(1) >*/
L1:
if (gnd_1.ifar == 2 || gnd_1.ifar == 5) {
s_copy(hclif, hpol, 6L, 6L);
}
/*< IF( IFAR.EQ.3.OR. IFAR.EQ.6) HCLIF= HCIR >*/
if (gnd_1.ifar == 3 || gnd_1.ifar == 6) {
s_copy(hclif, hcir, 6L, 6L);
}
/*< CL= CLT/ WLAM >*/
gnd_1.cl = fpat_1.clt / data_1.wlam;
/*< CH= CHT/ WLAM >*/
gnd_1.ch = fpat_1.cht / data_1.wlam;
/*< ZRATI2= SQRT(1./ CMPLX( EPSR2,- SIG2* WLAM*59.96)) >*/
d__2 = -fpat_1.sig2 * data_1.wlam;
d__1 = d__2 * 59.96;
z__3.r = fpat_1.epsr2, z__3.i = d__1;
z_div(&z__2, &c_b48, &z__3);
z_sqrt(&z__1, &z__2);
gnd_1.zrati2.r = z__1.r, gnd_1.zrati2.i = z__1.i;
/*< WRITE( 6,37) HCLIF, CLT, CHT, EPSR2, SIG2 >*/
s_wsfe(&io___1777);
do_fio(&c__1, hclif, 6L);
do_fio(&c__1, (char *)&fpat_1.clt, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fpat_1.cht, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fpat_1.epsr2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&fpat_1.sig2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 2 IF( IFAR.NE.1) GOTO 3 >*/
L2:
if (gnd_1.ifar != 1) {
goto L3;
}
/*< WRITE( 6,41) >*/
s_wsfe(&io___1778);
e_wsfe();
/*< GOTO 5 >*/
goto L5;
/*< 3 I=2* IPD+1 >*/
L3:
i = (fpat_1.ipd << 1) + 1;
/*< J= I+1 >*/
j = i + 1;
/*< ITMP1=2* IAX+1 >*/
itmp1 = (fpat_1.iax << 1) + 1;
/*< ITMP2= ITMP1+1 >*/
itmp2 = itmp1 + 1;
/*< WRITE( 6,38) >*/
s_wsfe(&io___1783);
e_wsfe();
/*< IF( RFLD.LT.1.D-20) GOTO 4 >*/
if (fpat_1.rfld < 1e-20) {
goto L4;
}
/*< EXRM=1./ RFLD >*/
exrm = 1. / fpat_1.rfld;
/*< EXRA= RFLD/ WLAM >*/
exra = fpat_1.rfld / data_1.wlam;
/*< EXRA=-360.*( EXRA- AINT( EXRA)) >*/
exra = (exra - d_int(&exra)) * -360.;
/*< WRITE( 6,39) RFLD, EXRM, EXRA >*/
s_wsfe(&io___1786);
do_fio(&c__1, (char *)&fpat_1.rfld, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&exrm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&exra, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 4 WRITE( 6,40) IGTP( I), IGTP( J), IGAX( ITMP1), IGAX( ITMP2) >*/
L4:
s_wsfe(&io___1787);
do_fio(&c__1, (char *)&igtp[i - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&igtp[j - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&igax[itmp1 - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&igax[itmp2 - 1], (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 5 IF( IXTYP.EQ.0.OR. IXTYP.EQ.5) GOTO 7 >*/
L5:
if (fpat_1.ixtyp == 0 || fpat_1.ixtyp == 5) {
goto L7;
}
/*< IF( IXTYP.EQ.4) GOTO 6 >*/
if (fpat_1.ixtyp == 4) {
goto L6;
}
/*< PRAD=0. >*/
prad = 0.;
/*< GCON=4.* PI/(1.+ XPR6* XPR6) >*/
gcon = pi * 4. / (fpat_1.xpr6 * fpat_1.xpr6 + 1.);
/*< GCOP= GCON >*/
gcop = gcon;
/*< GOTO 8 >*/
goto L8;
/*< 6 PINR=394.51* XPR6* XPR6* WLAM* WLAM >*/
L6:
d__3 = fpat_1.xpr6 * 394.51;
d__2 = d__3 * fpat_1.xpr6;
d__1 = d__2 * data_1.wlam;
fpat_1.pinr = d__1 * data_1.wlam;
/*< 7 GCOP= WLAM* WLAM*2.* PI/(376.73* PINR) >*/
L7:
d__2 = data_1.wlam * data_1.wlam;
d__1 = d__2 * 2.;
gcop = d__1 * pi / (fpat_1.pinr * 376.73);
/*< PRAD= PINR- PLOSS- PNLR >*/
prad = fpat_1.pinr - fpat_1.ploss - fpat_1.pnlr;
/*< GCON= GCOP >*/
gcon = gcop;
/*< IF( IPD.NE.0) GCON= GCON* PINR/ PRAD >*/
if (fpat_1.ipd != 0) {
gcon = gcon * fpat_1.pinr / prad;
}
/*< 8 I=0 >*/
L8:
i = 0;
/*< GMAX=-1.E10 >*/
gmax = -1e10;
/*< PINT=0. >*/
pint = 0.;
/*< TMP1= DPH* TA >*/
tmp1 = fpat_1.dph * ta;
/*< TMP2=.5* DTH* TA >*/
d__1 = fpat_1.dth * .5;
tmp2 = d__1 * ta;
/*< PHI= PHIS- DPH >*/
phi = fpat_1.phis - fpat_1.dph;
/*< DO 29 KPH=1, NPH >*/
i__1 = fpat_1.nph;
for (kph = 1; kph <= i__1; ++kph) {
/*< PHI= PHI+ DPH >*/
phi += fpat_1.dph;
/*< PHA= PHI* TA >*/
pha = phi * ta;
/*< THET= THETS- DTH >*/
thet = fpat_1.thets - fpat_1.dth;
/*< DO 29 KTH=1, NTH >*/
i__2 = fpat_1.nth;
for (kth = 1; kth <= i__2; ++kth) {
/*< THET= THET+ DTH >*/
thet += fpat_1.dth;
/*< IF( KSYMP.EQ.2.AND. THET.GT.90.01.AND. IFAR.NE.1) GOTO 29 >*/
if (gnd_1.ksymp == 2 && thet > 90.01 && gnd_1.ifar != 1) {
goto L29;
}
/*< THA= THET* TA >*/
tha = thet * ta;
/*< IF( IFAR.EQ.1) GOTO 9 >*/
if (gnd_1.ifar == 1) {
goto L9;
}
/*< CALL FFLD( THA, PHA, ETH, EPH) >*/
ffld_(&tha, &pha, ð, &eph);
/*< GOTO 10 >*/
goto L10;
/*< >*/
L9:
d__1 = fpat_1.rfld / data_1.wlam;
d__2 = thet / data_1.wlam;
gfld_(&d__1, &pha, &d__2, ð, &eph, &erd, &gnd_1.zrati, &
gnd_1.ksymp);
/*< ERDM= ABS( ERD) >*/
erdm = z_abs(&erd);
/*< ERDA= CANG( ERD) >*/
erda = cang_(&erd);
/*< 10 ETHM2= REAL( ETH* CONJG( ETH)) >*/
L10:
d_cnjg(&z__2, ð);
z__1.r = eth.r * z__2.r - eth.i * z__2.i, z__1.i = eth.r * z__2.i
+ eth.i * z__2.r;
ethm2 = z__1.r;
/*< ETHM= SQRT( ETHM2) >*/
ethm = sqrt(ethm2);
/*< ETHA= CANG( ETH) >*/
etha = cang_(ð);
/*< EPHM2= REAL( EPH* CONJG( EPH)) >*/
d_cnjg(&z__2, &eph);
z__1.r = eph.r * z__2.r - eph.i * z__2.i, z__1.i = eph.r * z__2.i
+ eph.i * z__2.r;
ephm2 = z__1.r;
/*< EPHM= SQRT( EPHM2) >*/
ephm = sqrt(ephm2);
/*< EPHA= CANG( EPH) >*/
epha = cang_(&eph);
/* ELLIPTICAL POLARIZATION CALC. */
/*< IF( IFAR.EQ.1) GOTO 28 >*/
if (gnd_1.ifar == 1) {
goto L28;
}
/*< IF( ETHM2.GT.1.D-20.OR. EPHM2.GT.1.D-20) GOTO 11 >*/
if (ethm2 > 1e-20 || ephm2 > 1e-20) {
goto L11;
}
/*< TILTA=0. >*/
tilta = 0.;
/*< EMAJR2=0. >*/
emajr2 = 0.;
/*< EMINR2=0. >*/
eminr2 = 0.;
/*< AXRAT=0. >*/
axrat = 0.;
/*< ISENS= HBLK >*/
s_copy(isens, hblk, 6L, 6L);
/*< GOTO 16 >*/
goto L16;
/*< 11 DFAZ= EPHA- ETHA >*/
L11:
dfaz = epha - etha;
/*< IF( EPHA.LT.0.) GOTO 12 >*/
if (epha < 0.) {
goto L12;
}
/*< DFAZ2= DFAZ-360. >*/
dfaz2 = dfaz - 360.;
/*< GOTO 13 >*/
goto L13;
/*< 12 DFAZ2= DFAZ+360. >*/
L12:
dfaz2 = dfaz + 360.;
/*< 13 IF( ABS( DFAZ).GT. ABS( DFAZ2)) DFAZ= DFAZ2 >*/
L13:
if (abs(dfaz) > abs(dfaz2)) {
dfaz = dfaz2;
}
/*< CDFAZ= COS( DFAZ* TA) >*/
cdfaz = cos(dfaz * ta);
/*< TSTOR1= ETHM2- EPHM2 >*/
tstor1 = ethm2 - ephm2;
/*< TSTOR2=2.* EPHM* ETHM* CDFAZ >*/
d__2 = ephm * 2.;
d__1 = d__2 * ethm;
tstor2 = d__1 * cdfaz;
/*< TILTA=.5* ATGN2( TSTOR2, TSTOR1) >*/
tilta = atgn2_(&tstor2, &tstor1) * .5;
/*< STILTA= SIN( TILTA) >*/
stilta = sin(tilta);
/*< TSTOR1= TSTOR1* STILTA* STILTA >*/
d__1 = tstor1 * stilta;
tstor1 = d__1 * stilta;
/*< TSTOR2= TSTOR2* STILTA* COS( TILTA) >*/
d__1 = tstor2 * stilta;
tstor2 = d__1 * cos(tilta);
/*< EMAJR2=- TSTOR1+ TSTOR2+ ETHM2 >*/
d__1 = -tstor1 + tstor2;
emajr2 = d__1 + ethm2;
/*< EMINR2= TSTOR1- TSTOR2+ EPHM2 >*/
eminr2 = tstor1 - tstor2 + ephm2;
/*< IF( EMINR2.LT.0.) EMINR2=0. >*/
if (eminr2 < 0.) {
eminr2 = 0.;
}
/*< AXRAT= SQRT( EMINR2/ EMAJR2) >*/
axrat = sqrt(eminr2 / emajr2);
/*< TILTA= TILTA* TD >*/
tilta *= td;
/*< IF( AXRAT.GT.1.D-5) GOTO 14 >*/
if (axrat > 1e-5) {
goto L14;
}
/*< ISENS= HPOL(1) >*/
s_copy(isens, hpol, 6L, 6L);
/*< GOTO 16 >*/
goto L16;
/*< 14 IF( DFAZ.GT.0.) GOTO 15 >*/
L14:
if (dfaz > 0.) {
goto L15;
}
/*< ISENS= HPOL(2) >*/
s_copy(isens, hpol + 6, 6L, 6L);
/*< GOTO 16 >*/
goto L16;
/*< 15 ISENS= HPOL(3) >*/
L15:
s_copy(isens, hpol + 12, 6L, 6L);
/*< 16 GNMJ= DB10( GCON* EMAJR2) >*/
L16:
d__1 = gcon * emajr2;
gnmj = db10_(&d__1);
/*< GNMN= DB10( GCON* EMINR2) >*/
d__1 = gcon * eminr2;
gnmn = db10_(&d__1);
/*< GNV= DB10( GCON* ETHM2) >*/
d__1 = gcon * ethm2;
gnv = db10_(&d__1);
/*< GNH= DB10( GCON* EPHM2) >*/
d__1 = gcon * ephm2;
gnh = db10_(&d__1);
/*< GTOT= DB10( GCON*( ETHM2+ EPHM2)) >*/
d__1 = gcon * (ethm2 + ephm2);
gtot = db10_(&d__1);
/*< IF( INOR.LT.1) GOTO 23 >*/
if (fpat_1.inor < 1) {
goto L23;
}
/*< I= I+1 >*/
++i;
/*< IF( I.GT. NORMAX) GOTO 23 >*/
if (i > normax) {
goto L23;
}
/*< GOTO (17,18,19,20,21), INOR >*/
switch ((int)fpat_1.inor) {
case 1: goto L17;
case 2: goto L18;
case 3: goto L19;
case 4: goto L20;
case 5: goto L21;
}
/*< 17 TSTOR1= GNMJ >*/
L17:
tstor1 = gnmj;
/*< GOTO 22 >*/
goto L22;
/*< 18 TSTOR1= GNMN >*/
L18:
tstor1 = gnmn;
/*< GOTO 22 >*/
goto L22;
/*< 19 TSTOR1= GNV >*/
L19:
tstor1 = gnv;
/*< GOTO 22 >*/
goto L22;
/*< 20 TSTOR1= GNH >*/
L20:
tstor1 = gnh;
/*< GOTO 22 >*/
goto L22;
/*< 21 TSTOR1= GTOT >*/
L21:
tstor1 = gtot;
/*< 22 GAIN( I)= TSTOR1 >*/
L22:
scratm_3.gain[i - 1] = tstor1;
/*< IF( TSTOR1.GT. GMAX) GMAX= TSTOR1 >*/
if (tstor1 > gmax) {
gmax = tstor1;
}
/*< 23 IF( IAVP.EQ.0) GOTO 24 >*/
L23:
if (fpat_1.iavp == 0) {
goto L24;
}
/*< TSTOR1= GCOP*( ETHM2+ EPHM2) >*/
tstor1 = gcop * (ethm2 + ephm2);
/*< TMP3= THA- TMP2 >*/
tmp3 = tha - tmp2;
/*< TMP4= THA+ TMP2 >*/
tmp4 = tha + tmp2;
/*< IF( KTH.EQ.1) TMP3= THA >*/
if (kth == 1) {
tmp3 = tha;
}
/*< IF( KTH.EQ. NTH) TMP4= THA >*/
if (kth == fpat_1.nth) {
tmp4 = tha;
}
/*< DA= ABS( TMP1*( COS( TMP3)- COS( TMP4))) >*/
da = (d__1 = tmp1 * (cos(tmp3) - cos(tmp4)), abs(d__1));
/*< IF( KPH.EQ.1.OR. KPH.EQ. NPH) DA=.5* DA >*/
if (kph == 1 || kph == fpat_1.nph) {
da *= .5;
}
/*< PINT= PINT+ TSTOR1* DA >*/
pint += tstor1 * da;
/*< IF( IAVP.EQ.2) GOTO 29 >*/
if (fpat_1.iavp == 2) {
goto L29;
}
/*< 24 IF( IAX.EQ.1) GOTO 25 >*/
L24:
if (fpat_1.iax == 1) {
goto L25;
}
/*< TMP5= GNMJ >*/
tmp5 = gnmj;
/*< TMP6= GNMN >*/
tmp6 = gnmn;
/*< GOTO 26 >*/
goto L26;
/*< 25 TMP5= GNV >*/
L25:
tmp5 = gnv;
/*< TMP6= GNH >*/
tmp6 = gnh;
/*< 26 ETHM= ETHM* WLAM >*/
L26:
ethm *= data_1.wlam;
/*< EPHM= EPHM* WLAM >*/
ephm *= data_1.wlam;
/*< IF( RFLD.LT.1.D-20) GOTO 27 >*/
if (fpat_1.rfld < 1e-20) {
goto L27;
}
/*< ETHM= ETHM* EXRM >*/
ethm *= exrm;
/*< ETHA= ETHA+ EXRA >*/
etha += exra;
/*< EPHM= EPHM* EXRM >*/
ephm *= exrm;
/*< EPHA= EPHA+ EXRA >*/
epha += exra;
/* GO TO 29 */
/* *** */
/* 28 WRITE(6,43) RFLD,PHI,THET,ETHM,ETHA,EPHM,EPHA,ERDM,ERDA
*/
/*< >*/
L27:
s_wsfe(&io___1833);
do_fio(&c__1, (char *)&thet, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&phi, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)>ot, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&axrat, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tilta, (ftnlen)sizeof(doublereal));
do_fio(&c__1, isens, 6L);
do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< IF( IPLP1.NE.3) GOTO 299 >*/
if (plot_1.iplp1 != 3) {
goto L299;
}
/*< IF( IPLP3.EQ.0) GOTO 290 >*/
if (plot_1.iplp3 == 0) {
goto L290;
}
/*< IF( IPLP2.EQ.1.AND. IPLP3.EQ.1) WRITE( 8,*) THET, ETHM, ETHA >*/
if (plot_1.iplp2 == 1 && plot_1.iplp3 == 1) {
s_wsle(&io___1834);
do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)ðm, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)ða, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.1.AND. IPLP3.EQ.2) WRITE( 8,*) THET, EPHM, EPHA >*/
if (plot_1.iplp2 == 1 && plot_1.iplp3 == 2) {
s_wsle(&io___1835);
do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)&ephm, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)&epha, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.2.AND. IPLP3.EQ.1) WRITE( 8,*) PHI, ETHM, ETHA >*/
if (plot_1.iplp2 == 2 && plot_1.iplp3 == 1) {
s_wsle(&io___1836);
do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)ðm, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)ða, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.2.AND. IPLP3.EQ.2) WRITE( 8,*) PHI, EPHM, EPHA >*/
if (plot_1.iplp2 == 2 && plot_1.iplp3 == 2) {
s_wsle(&io___1837);
do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)&ephm, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)&epha, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP4.EQ.0) GOTO 299 >*/
if (plot_1.iplp4 == 0) {
goto L299;
}
/*< 290 IF( IPLP2.EQ.1.AND. IPLP4.EQ.1) WRITE( 8,*) THET, TMP5 >*/
L290:
if (plot_1.iplp2 == 1 && plot_1.iplp4 == 1) {
s_wsle(&io___1838);
do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.1.AND. IPLP4.EQ.2) WRITE( 8,*) THET, TMP6 >*/
if (plot_1.iplp2 == 1 && plot_1.iplp4 == 2) {
s_wsle(&io___1839);
do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.1.AND. IPLP4.EQ.3) WRITE( 8,*) THET, GTOT >*/
if (plot_1.iplp2 == 1 && plot_1.iplp4 == 3) {
s_wsle(&io___1840);
do_lio(&c__5, &c__1, (char *)&thet, (ftnlen)sizeof(doublereal)
);
do_lio(&c__5, &c__1, (char *)>ot, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.2.AND. IPLP4.EQ.1) WRITE( 8,*) PHI, TMP5 >*/
if (plot_1.iplp2 == 2 && plot_1.iplp4 == 1) {
s_wsle(&io___1841);
do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.2.AND. IPLP4.EQ.2) WRITE( 8,*) PHI, TMP6 >*/
if (plot_1.iplp2 == 2 && plot_1.iplp4 == 2) {
s_wsle(&io___1842);
do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< IF( IPLP2.EQ.2.AND. IPLP4.EQ.3) WRITE( 8,*) PHI, GTOT >*/
if (plot_1.iplp2 == 2 && plot_1.iplp4 == 3) {
s_wsle(&io___1843);
do_lio(&c__5, &c__1, (char *)&phi, (ftnlen)sizeof(doublereal))
;
do_lio(&c__5, &c__1, (char *)>ot, (ftnlen)sizeof(doublereal)
);
e_wsle();
}
/*< GOTO 299 >*/
goto L299;
/*< >*/
L28:
s_wsfe(&io___1844);
do_fio(&c__1, (char *)&fpat_1.rfld, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&phi, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&thet, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)ðm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)ða, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&ephm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&epha, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&erdm, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&erda, (ftnlen)sizeof(doublereal));
e_wsfe();
/* *** */
/*< 299 CONTINUE >*/
L299:
/*< 29 CONTINUE >*/
L29:
;
}
}
/*< IF( IAVP.EQ.0) GOTO 30 >*/
if (fpat_1.iavp == 0) {
goto L30;
}
/*< TMP3= THETS* TA >*/
tmp3 = fpat_1.thets * ta;
/*< TMP4= TMP3+ DTH* TA* DFLOAT( NTH-1) >*/
d__1 = fpat_1.dth * ta;
tmp4 = tmp3 + d__1 * (doublereal) (fpat_1.nth - 1);
/*< TMP3= ABS( DPH* TA* DFLOAT( NPH-1)*( COS( TMP3)- COS( TMP4))) >*/
d__3 = fpat_1.dph * ta;
d__2 = d__3 * (doublereal) (fpat_1.nph - 1);
tmp3 = (d__1 = d__2 * (cos(tmp3) - cos(tmp4)), abs(d__1));
/*< PINT= PINT/ TMP3 >*/
pint /= tmp3;
/*< TMP3= TMP3/ PI >*/
tmp3 /= pi;
/*< WRITE( 6,44) PINT, TMP3 >*/
s_wsfe(&io___1845);
do_fio(&c__1, (char *)&pint, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 30 IF( INOR.EQ.0) GOTO 34 >*/
L30:
if (fpat_1.inor == 0) {
goto L34;
}
/*< IF( ABS( GNOR).GT.1.D-20) GMAX= GNOR >*/
if (abs(fpat_1.gnor) > 1e-20) {
gmax = fpat_1.gnor;
}
/*< ITMP1=( INOR-1)*2+1 >*/
itmp1 = (fpat_1.inor - 1 << 1) + 1;
/*< ITMP2= ITMP1+1 >*/
itmp2 = itmp1 + 1;
/*< WRITE( 6,45) IGNTP( ITMP1), IGNTP( ITMP2), GMAX >*/
s_wsfe(&io___1846);
do_fio(&c__1, (char *)&igntp[itmp1 - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&igntp[itmp2 - 1], (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&gmax, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< ITMP2= NPH* NTH >*/
itmp2 = fpat_1.nph * fpat_1.nth;
/*< IF( ITMP2.GT. NORMAX) ITMP2= NORMAX >*/
if (itmp2 > normax) {
itmp2 = normax;
}
/*< ITMP1=( ITMP2+2)/3 >*/
itmp1 = (itmp2 + 2) / 3;
/*< ITMP2= ITMP1*3- ITMP2 >*/
itmp2 = itmp1 * 3 - itmp2;
/*< ITMP3= ITMP1 >*/
itmp3 = itmp1;
/*< ITMP4=2* ITMP1 >*/
itmp4 = itmp1 << 1;
/*< IF( ITMP2.EQ.2) ITMP4= ITMP4-1 >*/
if (itmp2 == 2) {
--itmp4;
}
/*< DO 31 I=1, ITMP1 >*/
i__2 = itmp1;
for (i = 1; i <= i__2; ++i) {
/*< ITMP3= ITMP3+1 >*/
++itmp3;
/*< ITMP4= ITMP4+1 >*/
++itmp4;
/*< J=( I-1)/ NTH >*/
j = (i - 1) / fpat_1.nth;
/*< TMP1= THETS+ DFLOAT( I- J* NTH-1)* DTH >*/
tmp1 = fpat_1.thets + (doublereal) (i - j * fpat_1.nth - 1) *
fpat_1.dth;
/*< TMP2= PHIS+ DFLOAT( J)* DPH >*/
tmp2 = fpat_1.phis + (doublereal) j * fpat_1.dph;
/*< J=( ITMP3-1)/ NTH >*/
j = (itmp3 - 1) / fpat_1.nth;
/*< TMP3= THETS+ DFLOAT( ITMP3- J* NTH-1)* DTH >*/
tmp3 = fpat_1.thets + (doublereal) (itmp3 - j * fpat_1.nth - 1) *
fpat_1.dth;
/*< TMP4= PHIS+ DFLOAT( J)* DPH >*/
tmp4 = fpat_1.phis + (doublereal) j * fpat_1.dph;
/*< J=( ITMP4-1)/ NTH >*/
j = (itmp4 - 1) / fpat_1.nth;
/*< TMP5= THETS+ DFLOAT( ITMP4- J* NTH-1)* DTH >*/
tmp5 = fpat_1.thets + (doublereal) (itmp4 - j * fpat_1.nth - 1) *
fpat_1.dth;
/*< TMP6= PHIS+ DFLOAT( J)* DPH >*/
tmp6 = fpat_1.phis + (doublereal) j * fpat_1.dph;
/*< TSTOR1= GAIN( I)- GMAX >*/
tstor1 = scratm_3.gain[i - 1] - gmax;
/*< IF( I.EQ. ITMP1.AND. ITMP2.NE.0) GOTO 32 >*/
if (i == itmp1 && itmp2 != 0) {
goto L32;
}
/*< TSTOR2= GAIN( ITMP3)- GMAX >*/
tstor2 = scratm_3.gain[itmp3 - 1] - gmax;
/*< PINT= GAIN( ITMP4)- GMAX >*/
pint = scratm_3.gain[itmp4 - 1] - gmax;
/*< >*/
/* L31: */
s_wsfe(&io___1849);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tstor2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp5, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp6, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&pint, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/*< GOTO 34 >*/
goto L34;
/*< 32 IF( ITMP2.EQ.2) GOTO 33 >*/
L32:
if (itmp2 == 2) {
goto L33;
}
/*< TSTOR2= GAIN( ITMP3)- GMAX >*/
tstor2 = scratm_3.gain[itmp3 - 1] - gmax;
/*< WRITE( 6,46) TMP1, TMP2, TSTOR1, TMP3, TMP4, TSTOR2 >*/
s_wsfe(&io___1850);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp3, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp4, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tstor2, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 34 >*/
goto L34;
/*< 33 WRITE( 6,46) TMP1, TMP2, TSTOR1 >*/
L33:
s_wsfe(&io___1851);
do_fio(&c__1, (char *)&tmp1, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tmp2, (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&tstor1, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< 34 RETURN >*/
L34:
return 0;
/*< 35 FORMAT(///,31X,'- - - FAR FIELD GROUND PARAMETERS - - -',//) >*/
/*< >*/
/*< >*/
/*< 38 FORMAT(///,48X,'- - - RADIATION PATTERNS - - -') >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/*< 43 FORMAT(3X,F9.2,2X,F7.2,2X,F9.2,1X,3(3X,1P,E11.4,2X,0P,F7.2)) >*/
/*< >*/
/*< >*/
/*< 46 FORMAT(3(1X,2F9.2,1X,F9.2,6X)) >*/
/*< END >*/
} /* rdpat_ */
#undef igntp
#undef igax
#undef igtp
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE READGM( GM, I1, I2, X1, Y1, Z1, X2, Y2, Z2, RAD) >*/
/* Subroutine */ int readgm_(gm, i1, i2, x1, y1, z1, x2, y2, z2, rad, gm_len)
char *gm;
integer *i1, *i2;
doublereal *x1, *y1, *z1, *x2, *y2, *z2, *rad;
ftnlen gm_len;
{
/* Format strings */
static char fmt_10[] = "(a)";
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3[3];
/* Builtin functions */
integer s_rsfe(), do_fio(), e_rsfe(), i_len();
/* Subroutine */ int s_copy();
integer i_indx();
/* Subroutine */ int s_cat();
integer s_wsle(), do_lio(), e_wsle();
/* Subroutine */ int s_stop();
/* Local variables */
static integer indd, inde;
static char line[133];
extern /* Subroutine */ int atof_();
static integer nlen, iarr[2];
extern /* Subroutine */ int atoi_();
static integer nlin;
static doublereal rarr[7];
static integer i;
extern /* Subroutine */ int str0pc_();
static integer ic, bp[9], ep[9];
static char buffer[132];
static integer ifound;
static char buffer1[132];
static integer ind;
/* Fortran I/O blocks */
static cilist io___1855 = { 0, 5, 0, fmt_10, 0 };
static cilist io___1871 = { 0, 6, 0, 0, 0 };
static cilist io___1872 = { 0, 6, 0, 0, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< INTEGER*4 NTOT >*/
/*< INTEGER*4 NINT >*/
/*< INTEGER*4 NFLT >*/
/*< PARAMETER (NTOT=9, NINT=2, NFLT=7) >*/
/*< INTEGER IARR( NINT), BP( NTOT), EP( NTOT) >*/
/*< DIMENSION RARR( NFLT) >*/
/*< CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132 >*/
/*< READ( 5,10) LINE >*/
s_rsfe(&io___1855);
do_fio(&c__1, line, 133L);
e_rsfe();
/*< 10 FORMAT(A) >*/
/*< NLIN= LEN(LINE) >*/
nlin = i_len(line, 133L);
/*< CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN)) >*/
str0pc_(line, line, nlin, nlin);
/*< IF( NLIN.LT.2) GOTO 110 >*/
if (nlin < 2) {
goto L110;
}
/*< IF( NLIN.LE.132) GOTO 20 >*/
if (nlin <= 132) {
goto L20;
}
/*< NLIN=132 >*/
nlin = 132;
/*< LINE(133:133)=' ' >*/
line[132] = ' ';
/*< 20 GM= LINE(1:2) >*/
L20:
s_copy(gm, line, 2L, 2L);
/*< NLIN= NLIN+1 >*/
++nlin;
/*< DO 30 I=1, NINT >*/
for (i = 1; i <= 2; ++i) {
/*< 30 IARR( I)=0 >*/
/* L30: */
iarr[i - 1] = 0;
}
/*< DO 40 I=1, NFLT >*/
for (i = 1; i <= 7; ++i) {
/*< 40 RARR( I)=0.0 >*/
/* L40: */
rarr[i - 1] = 0.;
}
/*< IC=2 >*/
ic = 2;
/*< IFOUND=0 >*/
ifound = 0;
/*< DO 70 I=1, NTOT >*/
for (i = 1; i <= 9; ++i) {
/*< 50 IC= IC+1 >*/
L50:
++ic;
/*< IF( IC.GE. NLIN) GOTO 80 >*/
if (ic >= nlin) {
goto L80;
}
/*< IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50 >*/
if (line[ic - 1] == ' ' || line[ic - 1] == ',') {
goto L50;
}
/* BEGINNING OF I-TH NUMERICAL FIELD */
/*< BP( I)= IC >*/
bp[i - 1] = ic;
/*< 60 IC= IC+1 >*/
L60:
++ic;
/*< IF( IC.GT. NLIN) GOTO 80 >*/
if (ic > nlin) {
goto L80;
}
/*< IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60 >*/
if (line[ic - 1] != ' ' && line[ic - 1] != ',') {
goto L60;
}
/* END OF I-TH NUMERICAL FIELD */
/*< EP( I)= IC-1 >*/
ep[i - 1] = ic - 1;
/*< IFOUND= I >*/
ifound = i;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< 80 CONTINUE >*/
L80:
/*< DO 90 I=1, MIN( IFOUND, NINT) >*/
i__1 = min(ifound,2);
for (i = 1; i <= i__1; ++i) {
/*< NLEN= EP( I)- BP( I)+1 >*/
nlen = ep[i - 1] - bp[i - 1] + 1;
/*< BUFFER= LINE( BP( I): EP( I)) >*/
i__2 = bp[i - 1] - 1;
s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
/*< IND= INDEX( BUFFER(1: NLEN),'.') >*/
ind = i_indx(buffer, ".", nlen, 1L);
/*< IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110 >*/
if (ind > 0 && ind < nlen) {
goto L110;
}
/* USER PUT DECIMAL POINT FOR INTEGER */
/*< IF( IND.EQ. NLEN) NLEN= NLEN-1 >*/
if (ind == nlen) {
--nlen;
}
/* READ( BUFFER(1: NLEN),111,ERR=110) IARR( I) */
/* 11 format(i3) */
/*< CALL ATOI(BUFFER,IARR(I)) >*/
atoi_(buffer, &iarr[i - 1], 132L);
/*< 90 CONTINUE >*/
/* L90: */
}
/*< DO 100 I= NINT+1, IFOUND >*/
i__1 = ifound;
for (i = 3; i <= i__1; ++i) {
/*< NLEN= EP( I)- BP( I)+1 >*/
nlen = ep[i - 1] - bp[i - 1] + 1;
/*< BUFFER= LINE( BP( I): EP( I)) >*/
i__2 = bp[i - 1] - 1;
s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
/*< IND= INDEX( BUFFER(1: NLEN),'.') >*/
ind = i_indx(buffer, ".", nlen, 1L);
/* USER FORGOT DECIMAL POINT FOR REAL */
/*< IF( IND.EQ.0) THEN >*/
if (ind == 0) {
/*< IF( NLEN.GE.15) GOTO 110 >*/
if (nlen >= 15) {
goto L110;
}
/*< INDE= INDEX( BUFFER(1: NLEN),'E') >*/
inde = i_indx(buffer, "E", nlen, 1L);
/*< NLEN= NLEN+1 >*/
++nlen;
/*< IF( INDE.EQ.0) THEN >*/
if (inde == 0) {
/*< BUFFER( NLEN: NLEN)='.' >*/
buffer[nlen - 1] = '.';
/*< ELSE >*/
} else {
/*< BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1) >*/
/* Writing concatenation */
i__3[0] = indd - 1, a__1[0] = buffer;
i__3[1] = 1, a__1[1] = ".";
i__3[2] = nlen - 1 - (inde - 1), a__1[2] = buffer + (inde - 1)
;
s_cat(buffer1, a__1, i__3, &c__3, 132L);
/*< BUFFER= BUFFER1 >*/
s_copy(buffer, buffer1, 132L, 132L);
/*< ENDIF >*/
}
/*< ENDIF >*/
}
/* READ( BUFFER(1: NLEN),112,ERR=110) RARR( I- NINT) */
/* 112 format (F15.7) */
/*< CALL ATOF(BUFFER,RARR( I- NINT)) >*/
atof_(buffer, &rarr[i - 3], 132L);
/*< 100 CONTINUE >*/
/* L100: */
}
/*< I1= IARR(1) >*/
*i1 = iarr[0];
/*< I2= IARR(2) >*/
*i2 = iarr[1];
/*< X1= RARR(1) >*/
*x1 = rarr[0];
/*< Y1= RARR(2) >*/
*y1 = rarr[1];
/*< Z1= RARR(3) >*/
*z1 = rarr[2];
/*< X2= RARR(4) >*/
*x2 = rarr[3];
/*< Y2= RARR(5) >*/
*y2 = rarr[4];
/*< Z2= RARR(6) >*/
*z2 = rarr[5];
/*< RAD= RARR(7) >*/
*rad = rarr[6];
/*< RETURN >*/
return 0;
/*< 110 WRITE( 6,*) ' GEOMETRY DATA CARD ERROR' >*/
L110:
s_wsle(&io___1871);
do_lio(&c__9, &c__1, " GEOMETRY DATA CARD ERROR", 25L);
e_wsle();
/*< WRITE( 6,*) LINE(1: MAX(1, NLIN-1)) >*/
s_wsle(&io___1872);
/* Computing MAX */
i__1 = 1, i__2 = nlin - 1;
do_lio(&c__9, &c__1, line, (max(i__1,i__2)));
e_wsle();
/*< STOP >*/
s_stop("", 0L);
/*< END >*/
} /* readgm_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE READMN( GM, I1, I2, I3, I4, F1, F2, F3, F4, F5, F6) >*/
/* Subroutine */ int readmn_(gm, i1, i2, i3, i4, f1, f2, f3, f4, f5, f6,
gm_len)
char *gm;
integer *i1, *i2, *i3, *i4;
doublereal *f1, *f2, *f3, *f4, *f5, *f6;
ftnlen gm_len;
{
/* Format strings */
static char fmt_10[] = "(a)";
/* System generated locals */
address a__1[3];
integer i__1, i__2, i__3[3];
/* Builtin functions */
integer s_rsfe(), do_fio(), e_rsfe(), i_len();
/* Subroutine */ int s_copy();
integer i_indx();
/* Subroutine */ int s_cat();
integer s_wsle(), do_lio(), e_wsle();
/* Subroutine */ int s_stop();
/* Local variables */
static integer indd, inde;
static char line[133];
extern /* Subroutine */ int atof_();
static integer nlen, iarr[4];
extern /* Subroutine */ int atoi_();
static integer nlin;
static doublereal rarr[6];
static integer i;
extern /* Subroutine */ int str0pc_();
static integer ic, bp[10], ep[10];
static char buffer[132];
static integer ifound;
static char buffer1[132];
static integer ind;
/* Fortran I/O blocks */
static cilist io___1873 = { 0, 5, 0, fmt_10, 0 };
static cilist io___1889 = { 0, 6, 0, 0, 0 };
static cilist io___1890 = { 0, 6, 0, 0, 0 };
/* *** */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< INTEGER*4 NTOT >*/
/*< INTEGER*4 NINT >*/
/*< INTEGER*4 NFLT >*/
/*< PARAMETER (NTOT=10, NINT=4, NFLT=6) >*/
/*< INTEGER IARR( NINT), BP( NTOT), EP( NTOT) >*/
/*< DIMENSION RARR( NFLT) >*/
/*< CHARACTER LINE*133, GM*2, BUFFER*132, BUFFER1*132 >*/
/*< READ( 5,10) LINE >*/
s_rsfe(&io___1873);
do_fio(&c__1, line, 133L);
e_rsfe();
/*< 10 FORMAT(A) >*/
/*< NLIN= LEN(LINE) >*/
nlin = i_len(line, 133L);
/*< CALL STR0PC( LINE(1: NLIN), LINE(1: NLIN)) >*/
str0pc_(line, line, nlin, nlin);
/*< IF( NLIN.LT.2) GOTO 110 >*/
if (nlin < 2) {
goto L110;
}
/*< IF( NLIN.LE.132) GOTO 20 >*/
if (nlin <= 132) {
goto L20;
}
/*< NLIN=132 >*/
nlin = 132;
/*< LINE(133:133)=' ' >*/
line[132] = ' ';
/*< 20 GM= LINE(1:2) >*/
L20:
s_copy(gm, line, 2L, 2L);
/*< NLIN= NLIN+1 >*/
++nlin;
/*< DO 30 I=1, NINT >*/
for (i = 1; i <= 4; ++i) {
/*< 30 IARR( I)=0 >*/
/* L30: */
iarr[i - 1] = 0;
}
/*< DO 40 I=1, NFLT >*/
for (i = 1; i <= 6; ++i) {
/*< 40 RARR( I)=0.0 >*/
/* L40: */
rarr[i - 1] = 0.;
}
/*< IC=2 >*/
ic = 2;
/*< IFOUND=0 >*/
ifound = 0;
/*< DO 70 I=1, NTOT >*/
for (i = 1; i <= 10; ++i) {
/*< 50 IC= IC+1 >*/
L50:
++ic;
/*< IF( IC.GE. NLIN) GOTO 80 >*/
if (ic >= nlin) {
goto L80;
}
/*< IF( LINE( IC: IC).EQ.' '.OR. LINE( IC: IC).EQ.',') GOTO 50 >*/
if (line[ic - 1] == ' ' || line[ic - 1] == ',') {
goto L50;
}
/* BEGINNING OF I-TH NUMERICAL FIELD */
/*< BP( I)= IC >*/
bp[i - 1] = ic;
/*< 60 IC= IC+1 >*/
L60:
++ic;
/*< IF( IC.GT. NLIN) GOTO 80 >*/
if (ic > nlin) {
goto L80;
}
/*< IF( LINE( IC: IC).NE.' '.AND. LINE( IC: IC).NE.',') GOTO 60 >*/
if (line[ic - 1] != ' ' && line[ic - 1] != ',') {
goto L60;
}
/* END OF I-TH NUMERICAL FIELD */
/*< EP( I)= IC-1 >*/
ep[i - 1] = ic - 1;
/*< IFOUND= I >*/
ifound = i;
/*< 70 CONTINUE >*/
/* L70: */
}
/*< 80 CONTINUE >*/
L80:
/*< DO 90 I=1, MIN( IFOUND, NINT) >*/
i__1 = min(ifound,4);
for (i = 1; i <= i__1; ++i) {
/*< NLEN= EP( I)- BP( I)+1 >*/
nlen = ep[i - 1] - bp[i - 1] + 1;
/*< BUFFER= LINE( BP( I): EP( I)) >*/
i__2 = bp[i - 1] - 1;
s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
/*< IND= INDEX( BUFFER(1: NLEN),'.') >*/
ind = i_indx(buffer, ".", nlen, 1L);
/*< IF( IND.GT.0.AND. IND.LT. NLEN) GOTO 110 >*/
if (ind > 0 && ind < nlen) {
goto L110;
}
/* USER PUT DECIMAL POINT FOR INTEGER */
/*< IF( IND.EQ. NLEN) NLEN= NLEN-1 >*/
if (ind == nlen) {
--nlen;
}
/* READ( BUFFER(1: NLEN),111,ERR=110) IARR( I) */
/* 111 format(I5) */
/*< CALL ATOI(BUFFER,IARR(I)) >*/
atoi_(buffer, &iarr[i - 1], 132L);
/*< 90 CONTINUE >*/
/* L90: */
}
/*< DO 100 I= NINT+1, IFOUND >*/
i__1 = ifound;
for (i = 5; i <= i__1; ++i) {
/*< NLEN= EP( I)- BP( I)+1 >*/
nlen = ep[i - 1] - bp[i - 1] + 1;
/*< BUFFER= LINE( BP( I): EP( I)) >*/
i__2 = bp[i - 1] - 1;
s_copy(buffer, line + i__2, 132L, ep[i - 1] - i__2);
/*< IND= INDEX( BUFFER(1: NLEN),'.') >*/
ind = i_indx(buffer, ".", nlen, 1L);
/* USER FORGOT DECIMAL POINT FOR REAL */
/*< IF( IND.EQ.0) THEN >*/
if (ind == 0) {
/*< IF( NLEN.GE.15) GOTO 110 >*/
if (nlen >= 15) {
goto L110;
}
/*< INDE= INDEX( BUFFER(1: NLEN),'E') >*/
inde = i_indx(buffer, "E", nlen, 1L);
/*< NLEN= NLEN+1 >*/
++nlen;
/*< IF( INDE.EQ.0) THEN >*/
if (inde == 0) {
/*< BUFFER( NLEN: NLEN)='.' >*/
buffer[nlen - 1] = '.';
/*< ELSE >*/
} else {
/*< BUFFER1= BUFFER(1: INDD-1)//'.'// BUFFER( INDE: NLEN-1) >*/
/* Writing concatenation */
i__3[0] = indd - 1, a__1[0] = buffer;
i__3[1] = 1, a__1[1] = ".";
i__3[2] = nlen - 1 - (inde - 1), a__1[2] = buffer + (inde - 1)
;
s_cat(buffer1, a__1, i__3, &c__3, 132L);
/*< BUFFER= BUFFER1 >*/
s_copy(buffer, buffer1, 132L, 132L);
/*< ENDIF >*/
}
/*< ENDIF >*/
}
/* READ( BUFFER(1: NLEN),112,ERR=110) RARR( I- NINT) */
/* 112 format(F15.7) */
/*< CALL ATOF(BUFFER,RARR( I- NINT)) >*/
atof_(buffer, &rarr[i - 5], 132L);
/*< 100 CONTINUE >*/
/* L100: */
}
/*< I1= IARR(1) >*/
*i1 = iarr[0];
/*< I2= IARR(2) >*/
*i2 = iarr[1];
/*< I3= IARR(3) >*/
*i3 = iarr[2];
/*< I4= IARR(4) >*/
*i4 = iarr[3];
/*< F1= RARR(1) >*/
*f1 = rarr[0];
/*< F2= RARR(2) >*/
*f2 = rarr[1];
/*< F3= RARR(3) >*/
*f3 = rarr[2];
/*< F4= RARR(4) >*/
*f4 = rarr[3];
/*< F5= RARR(5) >*/
*f5 = rarr[4];
/*< F6= RARR(6) >*/
*f6 = rarr[5];
/*< RETURN >*/
return 0;
/*< 110 WRITE( 6,*) ' FAULTY DATA CARD AFTER GEOMETRY SECTION' >*/
L110:
s_wsle(&io___1889);
do_lio(&c__9, &c__1, " FAULTY DATA CARD AFTER GEOMETRY SECTION",
49L);
e_wsle();
/*< WRITE( 6,*) LINE(1: MAX(1, NLIN-1)) >*/
s_wsle(&io___1890);
/* Computing MAX */
i__1 = 1, i__2 = nlin - 1;
do_lio(&c__9, &c__1, line, (max(i__1,i__2)));
e_wsle();
/*< STOP >*/
s_stop("", 0L);
/*< END >*/
} /* readmn_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE REBLK( B, BX, NB, NBX, N2C) >*/
/* Subroutine */ int reblk_(b, bx, nb, nbx, n2c)
doublecomplex *b, *bx;
integer *nb, *nbx, *n2c;
{
/* System generated locals */
integer b_dim1, b_offset, bx_dim1, bx_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
alist al__1;
/* Builtin functions */
integer f_rew(), s_rsue(), do_uio(), e_rsue(), s_wsue(), e_wsue();
/* Local variables */
static integer i, j, ib, ix, nib, npb, ibx, nix, npx;
/* Fortran I/O blocks */
static cilist io___1897 = { 0, 14, 0, 0, 0 };
static cilist io___1901 = { 0, 16, 0, 0, 0 };
/* *** */
/* REBLOCK ARRAY B IN N.G.F. SOLUTION FROM BLOCKS OF ROWS ON TAPE14 */
/* TO BLOCKS OF COLUMNS ON TAPE16 */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX B, BX >*/
/*< >*/
/*< DIMENSION B( NB,1), BX( NBX,1) >*/
/*< REWIND 16 >*/
/* Parameter adjustments */
bx_dim1 = *nbx;
bx_offset = bx_dim1 + 1;
bx -= bx_offset;
b_dim1 = *nb;
b_offset = b_dim1 + 1;
b -= b_offset;
/* Function Body */
al__1.aerr = 0;
al__1.aunit = 16;
f_rew(&al__1);
/*< NIB=0 >*/
nib = 0;
/*< NPB= NPBL >*/
npb = matpar_1.npbl;
/*< DO 3 IB=1, NBBL >*/
i__1 = matpar_1.nbbl;
for (ib = 1; ib <= i__1; ++ib) {
/*< IF( IB.EQ. NBBL) NPB= NLBL >*/
if (ib == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< NIX=0 >*/
nix = 0;
/*< NPX= NPBX >*/
npx = matpar_1.npbx;
/*< DO 2 IBX=1, NBBX >*/
i__2 = matpar_1.nbbx;
for (ibx = 1; ibx <= i__2; ++ibx) {
/*< IF( IBX.EQ. NBBX) NPX= NLBX >*/
if (ibx == matpar_1.nbbx) {
npx = matpar_1.nlbx;
}
/*< READ( 14) (( BX( I, J), I=1, NPX), J=1, N2C) >*/
s_rsue(&io___1897);
i__3 = *n2c;
for (j = 1; j <= i__3; ++j) {
i__4 = npx;
for (i = 1; i <= i__4; ++i) {
do_uio(&c__2, (char *)&bx[i + j * bx_dim1], (ftnlen)
sizeof(doublereal));
}
}
e_rsue();
/*< DO 1 I=1, NPX >*/
i__4 = npx;
for (i = 1; i <= i__4; ++i) {
/*< IX= I+ NIX >*/
ix = i + nix;
/*< DO 1 J=1, NPB >*/
i__3 = npb;
for (j = 1; j <= i__3; ++j) {
/*< 1 B( IX, J)= BX( I, J+ NIB) >*/
/* L1: */
i__5 = ix + j * b_dim1;
i__6 = i + (j + nib) * bx_dim1;
b[i__5].r = bx[i__6].r, b[i__5].i = bx[i__6].i;
}
}
/*< 2 NIX= NIX+ NPBX >*/
/* L2: */
nix += matpar_1.npbx;
}
/*< WRITE( 16) (( B( I, J), I=1, NB), J=1, NPB) >*/
s_wsue(&io___1901);
i__2 = npb;
for (j = 1; j <= i__2; ++j) {
i__5 = *nb;
for (i = 1; i <= i__5; ++i) {
do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_wsue();
/*< 3 NIB= NIB+ NPBL >*/
/* L3: */
nib += matpar_1.npbl;
}
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/*< REWIND 16 >*/
al__1.aerr = 0;
al__1.aunit = 16;
f_rew(&al__1);
/*< RETURN >*/
return 0;
/*< END >*/
} /* reblk_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE REFLC( IX, IY, IZ, ITX, NOP) >*/
/* Subroutine */ int reflc_(ix, iy, iz, itx, nop)
integer *ix, *iy, *iz, *itx, *nop;
{
/* Format strings */
static char fmt_24[] = "(\002 GEOMETRY DATA ERROR--SEGMENT,I5,26H LIES I\
N PLANE OF S\002,\002YMMETRY\002)";
static char fmt_25[] = "(\002 GEOMETRY DATA ERROR--PATCH,I4,26H LIES IN \
PLANE OF SYM\002,\002METRY\002)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
double cos(), sin();
/* Local variables */
static doublereal fnop;
static integer i, j, k, itagi;
static doublereal e1, e2;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal cs, xk, yk;
static integer nx;
static doublereal ss;
#define t1x ((doublereal *)&data_1 + 1800)
#define t1y ((doublereal *)&data_1 + 3000)
#define t1z ((doublereal *)&data_1 + 3600)
#define t2x ((doublereal *)&data_1 + 4201)
#define t2y ((doublereal *)&data_1 + 4601)
#define t2z ((doublereal *)&data_1 + 5001)
static doublereal sam;
static integer iti, nxx;
/* Fortran I/O blocks */
static cilist io___1916 = { 0, 6, 0, fmt_24, 0 };
static cilist io___1919 = { 0, 6, 0, fmt_25, 0 };
static cilist io___1920 = { 0, 6, 0, fmt_24, 0 };
static cilist io___1921 = { 0, 6, 0, fmt_25, 0 };
static cilist io___1922 = { 0, 6, 0, fmt_24, 0 };
static cilist io___1923 = { 0, 6, 0, fmt_25, 0 };
/* *** */
/* REFLC REFLECTS PARTIAL STRUCTURE ALONG X,Y, OR Z AXES OR ROTATES */
/* STRUCTURE TO COMPLETE A SYMMETRIC STRUCTURE. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< COMMON /ANGL/ SALP( NM) >*/
/*< >*/
/*< >*/
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< ITI= ITX >*/
iti = *itx;
/*< IF( IX.LT.0) GOTO 19 >*/
if (*ix < 0) {
goto L19;
}
/*< IF( NOP.EQ.0) RETURN >*/
if (*nop == 0) {
return 0;
}
/*< IPSYM=1 >*/
data_1.ipsym = 1;
/* REFLECT ALONG Z AXIS */
/*< IF( IZ.EQ.0) GOTO 6 >*/
if (*iz == 0) {
goto L6;
}
/*< IPSYM=2 >*/
data_1.ipsym = 2;
/*< IF( N.LT. N2) GOTO 3 >*/
if (data_1.n < data_1.n2) {
goto L3;
}
/*< DO 2 I= N2, N >*/
i__1 = data_1.n;
for (i = data_1.n2; i <= i__1; ++i) {
/*< NX= I+ N- N1 >*/
nx = i + data_1.n - data_1.n1;
/*< E1= Z( I) >*/
e1 = data_1.z[i - 1];
/*< E2= Z2( I) >*/
e2 = z2[i - 1];
/*< IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 1 >*/
if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
goto L1;
}
/*< WRITE( 6,24) I >*/
s_wsfe(&io___1916);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 1 X( NX)= X( I) >*/
L1:
data_1.x[nx - 1] = data_1.x[i - 1];
/*< Y( NX)= Y( I) >*/
data_1.y[nx - 1] = data_1.y[i - 1];
/*< Z( NX)=- E1 >*/
data_1.z[nx - 1] = -e1;
/*< X2( NX)= X2( I) >*/
x2[nx - 1] = x2[i - 1];
/*< Y2( NX)= Y2( I) >*/
y2[nx - 1] = y2[i - 1];
/*< Z2( NX)=- E2 >*/
z2[nx - 1] = -e2;
/*< ITAGI= ITAG( I) >*/
itagi = data_1.itag[i - 1];
/*< IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
if (itagi == 0) {
data_1.itag[nx - 1] = 0;
}
/*< IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
if (itagi != 0) {
data_1.itag[nx - 1] = itagi + iti;
}
/*< 2 BI( NX)= BI( I) >*/
/* L2: */
data_1.bi[nx - 1] = data_1.bi[i - 1];
}
/*< N= N*2- N1 >*/
data_1.n = (data_1.n << 1) - data_1.n1;
/*< ITI= ITI*2 >*/
iti <<= 1;
/*< 3 IF( M.LT. M2) GOTO 6 >*/
L3:
if (data_1.m < data_1.m2) {
goto L6;
}
/*< NXX= LD+1- M1 >*/
nxx = data_1.ld + 1 - data_1.m1;
/*< DO 5 I= M2, M >*/
i__1 = data_1.m;
for (i = data_1.m2; i <= i__1; ++i) {
/*< NXX= NXX-1 >*/
--nxx;
/*< NX= NXX- M+ M1 >*/
nx = nxx - data_1.m + data_1.m1;
/*< IF( ABS( Z( NXX)).GT.1.D-10) GOTO 4 >*/
if ((d__1 = data_1.z[nxx - 1], abs(d__1)) > 1e-10) {
goto L4;
}
/*< WRITE( 6,25) I >*/
s_wsfe(&io___1919);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 4 X( NX)= X( NXX) >*/
L4:
data_1.x[nx - 1] = data_1.x[nxx - 1];
/*< Y( NX)= Y( NXX) >*/
data_1.y[nx - 1] = data_1.y[nxx - 1];
/*< Z( NX)=- Z( NXX) >*/
data_1.z[nx - 1] = -data_1.z[nxx - 1];
/*< T1X( NX)= T1X( NXX) >*/
t1x[nx - 1] = t1x[nxx - 1];
/*< T1Y( NX)= T1Y( NXX) >*/
t1y[nx - 1] = t1y[nxx - 1];
/*< T1Z( NX)=- T1Z( NXX) >*/
t1z[nx - 1] = -t1z[nxx - 1];
/*< T2X( NX)= T2X( NXX) >*/
t2x[nx - 1] = t2x[nxx - 1];
/*< T2Y( NX)= T2Y( NXX) >*/
t2y[nx - 1] = t2y[nxx - 1];
/*< T2Z( NX)=- T2Z( NXX) >*/
t2z[nx - 1] = -t2z[nxx - 1];
/*< SALP( NX)=- SALP( NXX) >*/
angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
/*< 5 BI( NX)= BI( NXX) >*/
/* L5: */
data_1.bi[nx - 1] = data_1.bi[nxx - 1];
}
/*< M= M*2- M1 >*/
data_1.m = (data_1.m << 1) - data_1.m1;
/* REFLECT ALONG Y AXIS */
/*< 6 IF( IY.EQ.0) GOTO 12 >*/
L6:
if (*iy == 0) {
goto L12;
}
/*< IF( N.LT. N2) GOTO 9 >*/
if (data_1.n < data_1.n2) {
goto L9;
}
/*< DO 8 I= N2, N >*/
i__1 = data_1.n;
for (i = data_1.n2; i <= i__1; ++i) {
/*< NX= I+ N- N1 >*/
nx = i + data_1.n - data_1.n1;
/*< E1= Y( I) >*/
e1 = data_1.y[i - 1];
/*< E2= Y2( I) >*/
e2 = y2[i - 1];
/*< IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 7 >*/
if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
goto L7;
}
/*< WRITE( 6,24) I >*/
s_wsfe(&io___1920);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 7 X( NX)= X( I) >*/
L7:
data_1.x[nx - 1] = data_1.x[i - 1];
/*< Y( NX)=- E1 >*/
data_1.y[nx - 1] = -e1;
/*< Z( NX)= Z( I) >*/
data_1.z[nx - 1] = data_1.z[i - 1];
/*< X2( NX)= X2( I) >*/
x2[nx - 1] = x2[i - 1];
/*< Y2( NX)=- E2 >*/
y2[nx - 1] = -e2;
/*< Z2( NX)= Z2( I) >*/
z2[nx - 1] = z2[i - 1];
/*< ITAGI= ITAG( I) >*/
itagi = data_1.itag[i - 1];
/*< IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
if (itagi == 0) {
data_1.itag[nx - 1] = 0;
}
/*< IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
if (itagi != 0) {
data_1.itag[nx - 1] = itagi + iti;
}
/*< 8 BI( NX)= BI( I) >*/
/* L8: */
data_1.bi[nx - 1] = data_1.bi[i - 1];
}
/*< N= N*2- N1 >*/
data_1.n = (data_1.n << 1) - data_1.n1;
/*< ITI= ITI*2 >*/
iti <<= 1;
/*< 9 IF( M.LT. M2) GOTO 12 >*/
L9:
if (data_1.m < data_1.m2) {
goto L12;
}
/*< NXX= LD+1- M1 >*/
nxx = data_1.ld + 1 - data_1.m1;
/*< DO 11 I= M2, M >*/
i__1 = data_1.m;
for (i = data_1.m2; i <= i__1; ++i) {
/*< NXX= NXX-1 >*/
--nxx;
/*< NX= NXX- M+ M1 >*/
nx = nxx - data_1.m + data_1.m1;
/*< IF( ABS( Y( NXX)).GT.1.D-10) GOTO 10 >*/
if ((d__1 = data_1.y[nxx - 1], abs(d__1)) > 1e-10) {
goto L10;
}
/*< WRITE( 6,25) I >*/
s_wsfe(&io___1921);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 10 X( NX)= X( NXX) >*/
L10:
data_1.x[nx - 1] = data_1.x[nxx - 1];
/*< Y( NX)=- Y( NXX) >*/
data_1.y[nx - 1] = -data_1.y[nxx - 1];
/*< Z( NX)= Z( NXX) >*/
data_1.z[nx - 1] = data_1.z[nxx - 1];
/*< T1X( NX)= T1X( NXX) >*/
t1x[nx - 1] = t1x[nxx - 1];
/*< T1Y( NX)=- T1Y( NXX) >*/
t1y[nx - 1] = -t1y[nxx - 1];
/*< T1Z( NX)= T1Z( NXX) >*/
t1z[nx - 1] = t1z[nxx - 1];
/*< T2X( NX)= T2X( NXX) >*/
t2x[nx - 1] = t2x[nxx - 1];
/*< T2Y( NX)=- T2Y( NXX) >*/
t2y[nx - 1] = -t2y[nxx - 1];
/*< T2Z( NX)= T2Z( NXX) >*/
t2z[nx - 1] = t2z[nxx - 1];
/*< SALP( NX)=- SALP( NXX) >*/
angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
/*< 11 BI( NX)= BI( NXX) >*/
/* L11: */
data_1.bi[nx - 1] = data_1.bi[nxx - 1];
}
/*< M= M*2- M1 >*/
data_1.m = (data_1.m << 1) - data_1.m1;
/* REFLECT ALONG X AXIS */
/*< 12 IF( IX.EQ.0) GOTO 18 >*/
L12:
if (*ix == 0) {
goto L18;
}
/*< IF( N.LT. N2) GOTO 15 >*/
if (data_1.n < data_1.n2) {
goto L15;
}
/*< DO 14 I= N2, N >*/
i__1 = data_1.n;
for (i = data_1.n2; i <= i__1; ++i) {
/*< NX= I+ N- N1 >*/
nx = i + data_1.n - data_1.n1;
/*< E1= X( I) >*/
e1 = data_1.x[i - 1];
/*< E2= X2( I) >*/
e2 = x2[i - 1];
/*< IF( ABS( E1)+ ABS( E2).GT.1.D-5.AND. E1* E2.GE.-1.D-6) GOTO 13 >*/
if (abs(e1) + abs(e2) > 1e-5 && e1 * e2 >= -1e-6) {
goto L13;
}
/*< WRITE( 6,24) I >*/
s_wsfe(&io___1922);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 13 X( NX)=- E1 >*/
L13:
data_1.x[nx - 1] = -e1;
/*< Y( NX)= Y( I) >*/
data_1.y[nx - 1] = data_1.y[i - 1];
/*< Z( NX)= Z( I) >*/
data_1.z[nx - 1] = data_1.z[i - 1];
/*< X2( NX)=- E2 >*/
x2[nx - 1] = -e2;
/*< Y2( NX)= Y2( I) >*/
y2[nx - 1] = y2[i - 1];
/*< Z2( NX)= Z2( I) >*/
z2[nx - 1] = z2[i - 1];
/*< ITAGI= ITAG( I) >*/
itagi = data_1.itag[i - 1];
/*< IF( ITAGI.EQ.0) ITAG( NX)=0 >*/
if (itagi == 0) {
data_1.itag[nx - 1] = 0;
}
/*< IF( ITAGI.NE.0) ITAG( NX)= ITAGI+ ITI >*/
if (itagi != 0) {
data_1.itag[nx - 1] = itagi + iti;
}
/*< 14 BI( NX)= BI( I) >*/
/* L14: */
data_1.bi[nx - 1] = data_1.bi[i - 1];
}
/*< N= N*2- N1 >*/
data_1.n = (data_1.n << 1) - data_1.n1;
/*< 15 IF( M.LT. M2) GOTO 18 >*/
L15:
if (data_1.m < data_1.m2) {
goto L18;
}
/*< NXX= LD+1- M1 >*/
nxx = data_1.ld + 1 - data_1.m1;
/*< DO 17 I= M2, M >*/
i__1 = data_1.m;
for (i = data_1.m2; i <= i__1; ++i) {
/*< NXX= NXX-1 >*/
--nxx;
/*< NX= NXX- M+ M1 >*/
nx = nxx - data_1.m + data_1.m1;
/*< IF( ABS( X( NXX)).GT.1.D-10) GOTO 16 >*/
if ((d__1 = data_1.x[nxx - 1], abs(d__1)) > 1e-10) {
goto L16;
}
/*< WRITE( 6,25) I >*/
s_wsfe(&io___1923);
do_fio(&c__1, (char *)&i, (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 16 X( NX)=- X( NXX) >*/
L16:
data_1.x[nx - 1] = -data_1.x[nxx - 1];
/*< Y( NX)= Y( NXX) >*/
data_1.y[nx - 1] = data_1.y[nxx - 1];
/*< Z( NX)= Z( NXX) >*/
data_1.z[nx - 1] = data_1.z[nxx - 1];
/*< T1X( NX)=- T1X( NXX) >*/
t1x[nx - 1] = -t1x[nxx - 1];
/*< T1Y( NX)= T1Y( NXX) >*/
t1y[nx - 1] = t1y[nxx - 1];
/*< T1Z( NX)= T1Z( NXX) >*/
t1z[nx - 1] = t1z[nxx - 1];
/*< T2X( NX)=- T2X( NXX) >*/
t2x[nx - 1] = -t2x[nxx - 1];
/*< T2Y( NX)= T2Y( NXX) >*/
t2y[nx - 1] = t2y[nxx - 1];
/*< T2Z( NX)= T2Z( NXX) >*/
t2z[nx - 1] = t2z[nxx - 1];
/*< SALP( NX)=- SALP( NXX) >*/
angl_1.salp[nx - 1] = -angl_1.salp[nxx - 1];
/*< 17 BI( NX)= BI( NXX) >*/
/* L17: */
data_1.bi[nx - 1] = data_1.bi[nxx - 1];
}
/*< M= M*2- M1 >*/
data_1.m = (data_1.m << 1) - data_1.m1;
/* REPRODUCE STRUCTURE WITH ROTATION TO FORM CYLINDRICAL STRUCTURE */
/*< 18 RETURN >*/
L18:
return 0;
/*< 19 FNOP= NOP >*/
L19:
fnop = (doublereal) (*nop);
/*< IPSYM=-1 >*/
data_1.ipsym = -1;
/*< SAM=6.283185308D+0/ FNOP >*/
sam = 6.283185308 / fnop;
/*< CS= COS( SAM) >*/
cs = cos(sam);
/*< SS= SIN( SAM) >*/
ss = sin(sam);
/*< IF( N.LT. N2) GOTO 21 >*/
if (data_1.n < data_1.n2) {
goto L21;
}
/*< N= N1+( N- N1)* NOP >*/
data_1.n = data_1.n1 + (data_1.n - data_1.n1) * *nop;
/*< NX= NP+1 >*/
nx = data_1.np + 1;
/*< DO 20 I= NX, N >*/
i__1 = data_1.n;
for (i = nx; i <= i__1; ++i) {
/*< K= I- NP+ N1 >*/
k = i - data_1.np + data_1.n1;
/*< XK= X( K) >*/
xk = data_1.x[k - 1];
/*< YK= Y( K) >*/
yk = data_1.y[k - 1];
/*< X( I)= XK* CS- YK* SS >*/
data_1.x[i - 1] = xk * cs - yk * ss;
/*< Y( I)= XK* SS+ YK* CS >*/
data_1.y[i - 1] = xk * ss + yk * cs;
/*< Z( I)= Z( K) >*/
data_1.z[i - 1] = data_1.z[k - 1];
/*< XK= X2( K) >*/
xk = x2[k - 1];
/*< YK= Y2( K) >*/
yk = y2[k - 1];
/*< X2( I)= XK* CS- YK* SS >*/
x2[i - 1] = xk * cs - yk * ss;
/*< Y2( I)= XK* SS+ YK* CS >*/
y2[i - 1] = xk * ss + yk * cs;
/*< Z2( I)= Z2( K) >*/
z2[i - 1] = z2[k - 1];
/*< ITAGI= ITAG( K) >*/
itagi = data_1.itag[k - 1];
/*< IF( ITAGI.EQ.0) ITAG( I)=0 >*/
if (itagi == 0) {
data_1.itag[i - 1] = 0;
}
/*< IF( ITAGI.NE.0) ITAG( I)= ITAGI+ ITI >*/
if (itagi != 0) {
data_1.itag[i - 1] = itagi + iti;
}
/*< 20 BI( I)= BI( K) >*/
/* L20: */
data_1.bi[i - 1] = data_1.bi[k - 1];
}
/*< 21 IF( M.LT. M2) GOTO 23 >*/
L21:
if (data_1.m < data_1.m2) {
goto L23;
}
/*< M= M1+( M- M1)* NOP >*/
data_1.m = data_1.m1 + (data_1.m - data_1.m1) * *nop;
/*< NX= MP+1 >*/
nx = data_1.mp + 1;
/*< K= LD+1- M1 >*/
k = data_1.ld + 1 - data_1.m1;
/*< DO 22 I= NX, M >*/
i__1 = data_1.m;
for (i = nx; i <= i__1; ++i) {
/*< K= K-1 >*/
--k;
/*< J= K- MP+ M1 >*/
j = k - data_1.mp + data_1.m1;
/*< XK= X( K) >*/
xk = data_1.x[k - 1];
/*< YK= Y( K) >*/
yk = data_1.y[k - 1];
/*< X( J)= XK* CS- YK* SS >*/
data_1.x[j - 1] = xk * cs - yk * ss;
/*< Y( J)= XK* SS+ YK* CS >*/
data_1.y[j - 1] = xk * ss + yk * cs;
/*< Z( J)= Z( K) >*/
data_1.z[j - 1] = data_1.z[k - 1];
/*< XK= T1X( K) >*/
xk = t1x[k - 1];
/*< YK= T1Y( K) >*/
yk = t1y[k - 1];
/*< T1X( J)= XK* CS- YK* SS >*/
t1x[j - 1] = xk * cs - yk * ss;
/*< T1Y( J)= XK* SS+ YK* CS >*/
t1y[j - 1] = xk * ss + yk * cs;
/*< T1Z( J)= T1Z( K) >*/
t1z[j - 1] = t1z[k - 1];
/*< XK= T2X( K) >*/
xk = t2x[k - 1];
/*< YK= T2Y( K) >*/
yk = t2y[k - 1];
/*< T2X( J)= XK* CS- YK* SS >*/
t2x[j - 1] = xk * cs - yk * ss;
/*< T2Y( J)= XK* SS+ YK* CS >*/
t2y[j - 1] = xk * ss + yk * cs;
/*< T2Z( J)= T2Z( K) >*/
t2z[j - 1] = t2z[k - 1];
/*< SALP( J)= SALP( K) >*/
angl_1.salp[j - 1] = angl_1.salp[k - 1];
/*< 22 BI( J)= BI( K) >*/
/* L22: */
data_1.bi[j - 1] = data_1.bi[k - 1];
}
/*< 23 RETURN >*/
L23:
return 0;
/*< >*/
/*< >*/
/*< END >*/
} /* reflc_ */
#undef t2z
#undef t2y
#undef t2x
#undef t1z
#undef t1y
#undef t1x
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE ROM2( A, B, SUM, DMIN) >*/
/* Subroutine */ int rom2_(a, b, sum, dmin_)
doublereal *a, *b;
doublecomplex *sum;
doublereal *dmin_;
{
/* Initialized data */
static integer nm = 65536;
static integer nts = 4;
static integer nx = 1;
static integer n = 9;
static doublereal rx = 1e-4;
/* Format strings */
static char fmt_18[] = "(\002 ERROR - B LESS THAN A IN ROM2\002)";
static char fmt_19[] = "(\002 ROM2 -- STEP SIZE LIMITED AT Z =\002,1p,e1\
2.5)";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
integer s_wsfe(), e_wsfe();
/* Subroutine */ int s_stop();
double d_imag(), sqrt();
integer do_fio();
/* Local variables */
static doublereal zend;
extern /* Subroutine */ int test_();
static doublereal dzot, tmag1, tmag2;
static integer i;
static doublereal s, z;
extern /* Subroutine */ int sflds_();
static doublecomplex g1[9], g2[9], g3[9], g4[9], g5[9], t00, t01[9], t10[
9], t02, t11, t20[9];
static doublereal ep, ti, dz, ze;
static integer ns, nt;
static doublereal tr;
/* Fortran I/O blocks */
static cilist io___1940 = { 0, 6, 0, fmt_18, 0 };
static cilist io___1963 = { 0, 6, 0, fmt_19, 0 };
/* *** */
/* FOR THE SOMMERFELD GROUND OPTION, ROM2 INTEGRATES OVER THE SOURCE
*/
/* SEGMENT TO OBTAIN THE TOTAL FIELD DUE TO GROUND. THE METHOD OF */
/* VARIABLE INTERVAL WIDTH ROMBERG INTEGRATION IS USED. THERE ARE 9
*/
/* FIELD COMPONENTS - THE X, Y, AND Z COMPONENTS DUE TO CONSTANT, */
/* SINE, AND COSINE CURRENT DISTRIBUTIONS. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< >*/
/*< >*/
/*< DATA NM, NTS, NX, N/65536,4,1,9/, RX/1.D-4/ >*/
/* Parameter adjustments */
--sum;
/* Function Body */
/*< Z= A >*/
z = *a;
/*< ZE= B >*/
ze = *b;
/*< S= B- A >*/
s = *b - *a;
/*< IF( S.GE.0.) GOTO 1 >*/
if (s >= 0.) {
goto L1;
}
/*< WRITE( 6,18) >*/
s_wsfe(&io___1940);
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 1 EP= S/(1.E4* NM) >*/
L1:
ep = s / (nm * 1e4);
/*< ZEND= ZE- EP >*/
zend = ze - ep;
/*< DO 2 I=1, N >*/
i__1 = n;
for (i = 1; i <= i__1; ++i) {
/*< 2 SUM( I)=(0.,0.) >*/
/* L2: */
i__2 = i;
sum[i__2].r = 0., sum[i__2].i = 0.;
}
/*< NS= NX >*/
ns = nx;
/*< NT=0 >*/
nt = 0;
/*< CALL SFLDS( Z, G1) >*/
sflds_(&z, g1);
/*< 3 DZ= S/ NS >*/
L3:
dz = s / ns;
/*< IF( Z+ DZ.LE. ZE) GOTO 4 >*/
if (z + dz <= ze) {
goto L4;
}
/*< DZ= ZE- Z >*/
dz = ze - z;
/*< IF( DZ.LE. EP) GOTO 17 >*/
if (dz <= ep) {
goto L17;
}
/*< 4 DZOT= DZ*.5 >*/
L4:
dzot = dz * .5;
/*< CALL SFLDS( Z+ DZOT, G3) >*/
d__1 = z + dzot;
sflds_(&d__1, g3);
/*< CALL SFLDS( Z+ DZ, G5) >*/
d__1 = z + dz;
sflds_(&d__1, g5);
/*< 5 TMAG1=0. >*/
L5:
tmag1 = 0.;
/* EVALUATE 3 POINT ROMBERG RESULT AND TEST CONVERGENCE. */
/*< TMAG2=0. >*/
tmag2 = 0.;
/*< DO 6 I=1, N >*/
i__2 = n;
for (i = 1; i <= i__2; ++i) {
/*< T00=( G1( I)+ G5( I))* DZOT >*/
i__1 = i - 1;
i__3 = i - 1;
z__2.r = g1[i__1].r + g5[i__3].r, z__2.i = g1[i__1].i + g5[i__3].i;
z__1.r = dzot * z__2.r, z__1.i = dzot * z__2.i;
t00.r = z__1.r, t00.i = z__1.i;
/*< T01( I)=( T00+ DZ* G3( I))*.5 >*/
i__1 = i - 1;
i__3 = i - 1;
z__3.r = dz * g3[i__3].r, z__3.i = dz * g3[i__3].i;
z__2.r = t00.r + z__3.r, z__2.i = t00.i + z__3.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t01[i__1].r = z__1.r, t01[i__1].i = z__1.i;
/*< T10( I)=(4.* T01( I)- T00)/3. >*/
i__1 = i - 1;
i__3 = i - 1;
z__3.r = t01[i__3].r * 4., z__3.i = t01[i__3].i * 4.;
z__2.r = z__3.r - t00.r, z__2.i = z__3.i - t00.i;
z__1.r = z__2.r / 3., z__1.i = z__2.i / 3.;
t10[i__1].r = z__1.r, t10[i__1].i = z__1.i;
/*< IF( I.GT.3) GOTO 6 >*/
if (i > 3) {
goto L6;
}
/*< TR= REAL( T01( I)) >*/
i__1 = i - 1;
tr = t01[i__1].r;
/*< TI= AIMAG( T01( I)) >*/
ti = d_imag(&t01[i - 1]);
/*< TMAG1= TMAG1+ TR* TR+ TI* TI >*/
d__1 = tmag1 + tr * tr;
tmag1 = d__1 + ti * ti;
/*< TR= REAL( T10( I)) >*/
i__1 = i - 1;
tr = t10[i__1].r;
/*< TI= AIMAG( T10( I)) >*/
ti = d_imag(&t10[i - 1]);
/*< TMAG2= TMAG2+ TR* TR+ TI* TI >*/
d__1 = tmag2 + tr * tr;
tmag2 = d__1 + ti * ti;
/*< 6 CONTINUE >*/
L6:
;
}
/*< TMAG1= SQRT( TMAG1) >*/
tmag1 = sqrt(tmag1);
/*< TMAG2= SQRT( TMAG2) >*/
tmag2 = sqrt(tmag2);
/*< CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN) >*/
test_(&tmag1, &tmag2, &tr, &c_b594, &c_b594, &ti, dmin_);
/*< IF( TR.GT. RX) GOTO 8 >*/
if (tr > rx) {
goto L8;
}
/*< DO 7 I=1, N >*/
i__2 = n;
for (i = 1; i <= i__2; ++i) {
/*< 7 SUM( I)= SUM( I)+ T10( I) >*/
/* L7: */
i__1 = i;
i__3 = i;
i__4 = i - 1;
z__1.r = sum[i__3].r + t10[i__4].r, z__1.i = sum[i__3].i + t10[i__4]
.i;
sum[i__1].r = z__1.r, sum[i__1].i = z__1.i;
}
/*< NT= NT+2 >*/
nt += 2;
/*< GOTO 12 >*/
goto L12;
/*< 8 CALL SFLDS( Z+ DZ*.25, G2) >*/
L8:
d__1 = z + dz * .25;
sflds_(&d__1, g2);
/*< CALL SFLDS( Z+ DZ*.75, G4) >*/
d__1 = z + dz * .75;
sflds_(&d__1, g4);
/*< TMAG1=0. >*/
tmag1 = 0.;
/* EVALUATE 5 POINT ROMBERG RESULT AND TEST CONVERGENCE. */
/*< TMAG2=0. >*/
tmag2 = 0.;
/*< DO 9 I=1, N >*/
i__1 = n;
for (i = 1; i <= i__1; ++i) {
/*< T02=( T01( I)+ DZOT*( G2( I)+ G4( I)))*.5 >*/
i__3 = i - 1;
i__4 = i - 1;
i__2 = i - 1;
z__4.r = g2[i__4].r + g4[i__2].r, z__4.i = g2[i__4].i + g4[i__2].i;
z__3.r = dzot * z__4.r, z__3.i = dzot * z__4.i;
z__2.r = t01[i__3].r + z__3.r, z__2.i = t01[i__3].i + z__3.i;
z__1.r = z__2.r * .5, z__1.i = z__2.i * .5;
t02.r = z__1.r, t02.i = z__1.i;
/*< T11=(4.* T02- T01( I))/3. >*/
z__3.r = t02.r * 4., z__3.i = t02.i * 4.;
i__3 = i - 1;
z__2.r = z__3.r - t01[i__3].r, z__2.i = z__3.i - t01[i__3].i;
z__1.r = z__2.r / 3., z__1.i = z__2.i / 3.;
t11.r = z__1.r, t11.i = z__1.i;
/*< T20( I)=(16.* T11- T10( I))/15. >*/
i__3 = i - 1;
z__3.r = t11.r * 16., z__3.i = t11.i * 16.;
i__4 = i - 1;
z__2.r = z__3.r - t10[i__4].r, z__2.i = z__3.i - t10[i__4].i;
z__1.r = z__2.r / 15., z__1.i = z__2.i / 15.;
t20[i__3].r = z__1.r, t20[i__3].i = z__1.i;
/*< IF( I.GT.3) GOTO 9 >*/
if (i > 3) {
goto L9;
}
/*< TR= REAL( T11) >*/
tr = t11.r;
/*< TI= AIMAG( T11) >*/
ti = d_imag(&t11);
/*< TMAG1= TMAG1+ TR* TR+ TI* TI >*/
d__1 = tmag1 + tr * tr;
tmag1 = d__1 + ti * ti;
/*< TR= REAL( T20( I)) >*/
i__3 = i - 1;
tr = t20[i__3].r;
/*< TI= AIMAG( T20( I)) >*/
ti = d_imag(&t20[i - 1]);
/*< TMAG2= TMAG2+ TR* TR+ TI* TI >*/
d__1 = tmag2 + tr * tr;
tmag2 = d__1 + ti * ti;
/*< 9 CONTINUE >*/
L9:
;
}
/*< TMAG1= SQRT( TMAG1) >*/
tmag1 = sqrt(tmag1);
/*< TMAG2= SQRT( TMAG2) >*/
tmag2 = sqrt(tmag2);
/*< CALL TEST( TMAG1, TMAG2, TR,0.,0., TI, DMIN) >*/
test_(&tmag1, &tmag2, &tr, &c_b594, &c_b594, &ti, dmin_);
/*< IF( TR.GT. RX) GOTO 14 >*/
if (tr > rx) {
goto L14;
}
/*< 10 DO 11 I=1, N >*/
L10:
i__1 = n;
for (i = 1; i <= i__1; ++i) {
/*< 11 SUM( I)= SUM( I)+ T20( I) >*/
/* L11: */
i__3 = i;
i__4 = i;
i__2 = i - 1;
z__1.r = sum[i__4].r + t20[i__2].r, z__1.i = sum[i__4].i + t20[i__2]
.i;
sum[i__3].r = z__1.r, sum[i__3].i = z__1.i;
}
/*< NT= NT+1 >*/
++nt;
/*< 12 Z= Z+ DZ >*/
L12:
z += dz;
/*< IF( Z.GT. ZEND) GOTO 17 >*/
if (z > zend) {
goto L17;
}
/*< DO 13 I=1, N >*/
i__3 = n;
for (i = 1; i <= i__3; ++i) {
/*< 13 G1( I)= G5( I) >*/
/* L13: */
i__4 = i - 1;
i__2 = i - 1;
g1[i__4].r = g5[i__2].r, g1[i__4].i = g5[i__2].i;
}
/*< IF( NT.LT. NTS.OR. NS.LE. NX) GOTO 3 >*/
if (nt < nts || ns <= nx) {
goto L3;
}
/*< NS= NS/2 >*/
ns /= 2;
/*< NT=1 >*/
nt = 1;
/*< GOTO 3 >*/
goto L3;
/*< 14 NT=0 >*/
L14:
nt = 0;
/*< IF( NS.LT. NM) GOTO 15 >*/
if (ns < nm) {
goto L15;
}
/*< WRITE( 6,19) Z >*/
s_wsfe(&io___1963);
do_fio(&c__1, (char *)&z, (ftnlen)sizeof(doublereal));
e_wsfe();
/*< GOTO 10 >*/
goto L10;
/*< 15 NS= NS*2 >*/
L15:
ns <<= 1;
/*< DZ= S/ NS >*/
dz = s / ns;
/*< DZOT= DZ*.5 >*/
dzot = dz * .5;
/*< DO 16 I=1, N >*/
i__4 = n;
for (i = 1; i <= i__4; ++i) {
/*< G5( I)= G3( I) >*/
i__2 = i - 1;
i__3 = i - 1;
g5[i__2].r = g3[i__3].r, g5[i__2].i = g3[i__3].i;
/*< 16 G3( I)= G2( I) >*/
/* L16: */
i__2 = i - 1;
i__3 = i - 1;
g3[i__2].r = g2[i__3].r, g3[i__2].i = g2[i__3].i;
}
/*< GOTO 5 >*/
goto L5;
/*< 17 CONTINUE >*/
L17:
/*< RETURN >*/
return 0;
/*< 18 FORMAT(' ERROR - B LESS THAN A IN ROM2') >*/
/*< 19 FORMAT(' ROM2 -- STEP SIZE LIMITED AT Z =',1P,E12.5) >*/
/*< END >*/
} /* rom2_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE SBF( I, IS, AA, BB, CC) >*/
/* Subroutine */ int sbf_(i, is, aa, bb, cc)
integer *i, *is;
doublereal *aa, *bb, *cc;
{
/* Initialized data */
static doublereal pi = 3.141592654;
static integer jmax = 30;
/* Format strings */
static char fmt_25[] = "(\002 SBF - SEGMENT CONNECTION ERROR FOR SEGMEN\
T\002,i5)";
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double sin(), cos(), log();
integer s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer iend, jend, june, jcox, jsno, njun1, njun2;
static doublereal d, cd, aj, ap, sd, pp, pm, qp, qm, cdh, sdh, omc, sig,
xxi;
/* Fortran I/O blocks */
static cilist io___1987 = { 0, 6, 0, fmt_25, 0 };
/* *** */
/* COMPUTE COMPONENT OF BASIS FUNCTION I ON SEGMENT IS. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< DATA PI/3.141592654D+0/, JMAX/30/ >*/
/*< AA=0. >*/
*aa = 0.;
/*< BB=0. >*/
*bb = 0.;
/*< CC=0. >*/
*cc = 0.;
/*< JUNE=0 >*/
june = 0;
/*< JSNO=0 >*/
jsno = 0;
/*< PP=0. >*/
pp = 0.;
/*< JCOX= ICON1( I) >*/
jcox = data_1.icon1[*i - 1];
/*< IF( JCOX.GT.10000) JCOX= I >*/
if (jcox > 10000) {
jcox = *i;
}
/*< JEND=-1 >*/
jend = -1;
/*< IEND=-1 >*/
iend = -1;
/*< SIG=-1. >*/
sig = -1.;
/*< IF( JCOX) 1,11,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L11;
} else {
goto L2;
}
/*< 1 JCOX=- JCOX >*/
L1:
jcox = -jcox;
/*< GOTO 3 >*/
goto L3;
/*< 2 SIG=- SIG >*/
L2:
sig = -sig;
/*< JEND=- JEND >*/
jend = -jend;
/*< 3 JSNO= JSNO+1 >*/
L3:
++jsno;
/*< IF( JSNO.GE. JMAX) GOTO 24 >*/
if (jsno >= jmax) {
goto L24;
}
/*< D= PI* SI( JCOX) >*/
d = pi * data_1.si[jcox - 1];
/*< SDH= SIN( D) >*/
sdh = sin(d);
/*< CDH= COS( D) >*/
cdh = cos(d);
/*< SD=2.* SDH* CDH >*/
d__1 = sdh * 2.;
sd = d__1 * cdh;
/*< IF( D.GT.0.015) GOTO 4 >*/
if (d > .015) {
goto L4;
}
/*< OMC=4.* D* D >*/
d__1 = d * 4.;
omc = d__1 * d;
/*< OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
/*< GOTO 5 >*/
goto L5;
/*< 4 OMC=1.- CDH* CDH+ SDH* SDH >*/
L4:
omc = 1. - cdh * cdh + sdh * sdh;
/*< 5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0) >*/
L5:
aj = 1. / (log(1. / (pi * data_1.bi[jcox - 1])) - .577215664);
/*< PP= PP- OMC/ SD* AJ >*/
pp -= omc / sd * aj;
/*< IF( JCOX.NE. IS) GOTO 6 >*/
if (jcox != *is) {
goto L6;
}
/*< AA= AJ/ SD* SIG >*/
*aa = aj / sd * sig;
/*< BB= AJ/(2.* CDH) >*/
*bb = aj / (cdh * 2.);
/*< CC=- AJ/(2.* SDH)* SIG >*/
*cc = -aj / (sdh * 2.) * sig;
/*< JUNE= IEND >*/
june = iend;
/*< 6 IF( JCOX.EQ. I) GOTO 9 >*/
L6:
if (jcox == *i) {
goto L9;
}
/*< IF( JEND.EQ.1) GOTO 7 >*/
if (jend == 1) {
goto L7;
}
/*< JCOX= ICON1( JCOX) >*/
jcox = data_1.icon1[jcox - 1];
/*< GOTO 8 >*/
goto L8;
/*< 7 JCOX= ICON2( JCOX) >*/
L7:
jcox = data_1.icon2[jcox - 1];
/*< 8 IF( IABS( JCOX).EQ. I) GOTO 10 >*/
L8:
if (abs(jcox) == *i) {
goto L10;
}
/*< IF( JCOX) 1,24,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L24;
} else {
goto L2;
}
/*< 9 IF( JCOX.EQ. IS) BB=- BB >*/
L9:
if (jcox == *is) {
*bb = -(*bb);
}
/*< 10 IF( IEND.EQ.1) GOTO 12 >*/
L10:
if (iend == 1) {
goto L12;
}
/*< 11 PM=- PP >*/
L11:
pm = -pp;
/*< PP=0. >*/
pp = 0.;
/*< NJUN1= JSNO >*/
njun1 = jsno;
/*< JCOX= ICON2( I) >*/
jcox = data_1.icon2[*i - 1];
/*< IF( JCOX.GT.10000) JCOX= I >*/
if (jcox > 10000) {
jcox = *i;
}
/*< JEND=1 >*/
jend = 1;
/*< IEND=1 >*/
iend = 1;
/*< SIG=-1. >*/
sig = -1.;
/*< IF( JCOX) 1,12,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L12;
} else {
goto L2;
}
/*< 12 NJUN2= JSNO- NJUN1 >*/
L12:
njun2 = jsno - njun1;
/*< D= PI* SI( I) >*/
d = pi * data_1.si[*i - 1];
/*< SDH= SIN( D) >*/
sdh = sin(d);
/*< CDH= COS( D) >*/
cdh = cos(d);
/*< SD=2.* SDH* CDH >*/
d__1 = sdh * 2.;
sd = d__1 * cdh;
/*< CD= CDH* CDH- SDH* SDH >*/
cd = cdh * cdh - sdh * sdh;
/*< IF( D.GT.0.015) GOTO 13 >*/
if (d > .015) {
goto L13;
}
/*< OMC=4.* D* D >*/
d__1 = d * 4.;
omc = d__1 * d;
/*< OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
/*< GOTO 14 >*/
goto L14;
/*< 13 OMC=1.- CD >*/
L13:
omc = 1. - cd;
/*< 14 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0) >*/
L14:
ap = 1. / (log(1. / (pi * data_1.bi[*i - 1])) - .577215664);
/*< AJ= AP >*/
aj = ap;
/*< IF( NJUN1.EQ.0) GOTO 19 >*/
if (njun1 == 0) {
goto L19;
}
/*< IF( NJUN2.EQ.0) GOTO 21 >*/
if (njun2 == 0) {
goto L21;
}
/*< QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ) >*/
qp = sd * (pm * pp + aj * ap) + cd * (pm * ap - pp * aj);
/*< QM=( AP* OMC- PP* SD)/ QP >*/
qm = (ap * omc - pp * sd) / qp;
/*< QP=-( AJ* OMC+ PM* SD)/ QP >*/
qp = -(aj * omc + pm * sd) / qp;
/*< IF( JUNE) 15,18,16 >*/
if (june < 0) {
goto L15;
} else if (june == 0) {
goto L18;
} else {
goto L16;
}
/*< 15 AA= AA* QM >*/
L15:
*aa *= qm;
/*< BB= BB* QM >*/
*bb *= qm;
/*< CC= CC* QM >*/
*cc *= qm;
/*< GOTO 17 >*/
goto L17;
/*< 16 AA=- AA* QP >*/
L16:
*aa = -(*aa) * qp;
/*< BB= BB* QP >*/
*bb *= qp;
/*< CC=- CC* QP >*/
*cc = -(*cc) * qp;
/*< 17 IF( I.NE. IS) RETURN >*/
L17:
if (*i != *is) {
return 0;
}
/*< 18 AA= AA-1. >*/
L18:
*aa += -1.;
/*< BB= BB+( AJ* QM+ AP* QP)* SDH/ SD >*/
*bb += (aj * qm + ap * qp) * sdh / sd;
/*< CC= CC+( AJ* QM- AP* QP)* CDH/ SD >*/
*cc += (aj * qm - ap * qp) * cdh / sd;
/*< RETURN >*/
return 0;
/*< 19 IF( NJUN2.EQ.0) GOTO 23 >*/
L19:
if (njun2 == 0) {
goto L23;
}
/*< QP= PI* BI( I) >*/
qp = pi * data_1.bi[*i - 1];
/*< XXI= QP* QP >*/
xxi = qp * qp;
/*< XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qp * (1. - xxi * .5) / (1. - xxi);
/*< QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP)) >*/
qp = -(omc + xxi * sd) / (sd * (ap + xxi * pp) + cd * (xxi * ap - pp));
/*< IF( JUNE.NE.1) GOTO 20 >*/
if (june != 1) {
goto L20;
}
/*< AA=- AA* QP >*/
*aa = -(*aa) * qp;
/*< BB= BB* QP >*/
*bb *= qp;
/*< CC=- CC* QP >*/
*cc = -(*cc) * qp;
/*< IF( I.NE. IS) RETURN >*/
if (*i != *is) {
return 0;
}
/*< 20 AA= AA-1. >*/
L20:
*aa += -1.;
/*< D= CD- XXI* SD >*/
d = cd - xxi * sd;
/*< BB= BB+( SDH+ AP* QP*( CDH- XXI* SDH))/ D >*/
d__1 = ap * qp;
*bb += (sdh + d__1 * (cdh - xxi * sdh)) / d;
/*< CC= CC+( CDH+ AP* QP*( SDH+ XXI* CDH))/ D >*/
d__1 = ap * qp;
*cc += (cdh + d__1 * (sdh + xxi * cdh)) / d;
/*< RETURN >*/
return 0;
/*< 21 QM= PI* BI( I) >*/
L21:
qm = pi * data_1.bi[*i - 1];
/*< XXI= QM* QM >*/
xxi = qm * qm;
/*< XXI= QM*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qm * (1. - xxi * .5) / (1. - xxi);
/*< QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ)) >*/
qm = (omc + xxi * sd) / (sd * (aj - xxi * pm) + cd * (pm + xxi * aj));
/*< IF( JUNE.NE.-1) GOTO 22 >*/
if (june != -1) {
goto L22;
}
/*< AA= AA* QM >*/
*aa *= qm;
/*< BB= BB* QM >*/
*bb *= qm;
/*< CC= CC* QM >*/
*cc *= qm;
/*< IF( I.NE. IS) RETURN >*/
if (*i != *is) {
return 0;
}
/*< 22 AA= AA-1. >*/
L22:
*aa += -1.;
/*< D= CD- XXI* SD >*/
d = cd - xxi * sd;
/*< BB= BB+( AJ* QM*( CDH- XXI* SDH)- SDH)/ D >*/
d__1 = aj * qm;
*bb += (d__1 * (cdh - xxi * sdh) - sdh) / d;
/*< CC= CC+( CDH- AJ* QM*( SDH+ XXI* CDH))/ D >*/
d__1 = aj * qm;
*cc += (cdh - d__1 * (sdh + xxi * cdh)) / d;
/*< RETURN >*/
return 0;
/*< 23 AA=-1. >*/
L23:
*aa = -1.;
/*< QP= PI* BI( I) >*/
qp = pi * data_1.bi[*i - 1];
/*< XXI= QP* QP >*/
xxi = qp * qp;
/*< XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qp * (1. - xxi * .5) / (1. - xxi);
/*< CC=1./( CDH- XXI* SDH) >*/
*cc = 1. / (cdh - xxi * sdh);
/*< RETURN >*/
return 0;
/*< 24 WRITE( 6,25) I >*/
L24:
s_wsfe(&io___1987);
do_fio(&c__1, (char *)&(*i), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 25 FORMAT(' SBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
/*< END >*/
} /* sbf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE SFLDS( T, E) >*/
/* Subroutine */ int sflds_(t, e)
doublereal *t;
doublecomplex *e;
{
/* Initialized data */
static doublereal pi = 3.141592654;
static doublereal tp = 6.283185308;
static doublereal pot = 1.570796327;
/* System generated locals */
doublereal d__1, d__2;
doublecomplex z__1, z__2, z__3, z__4;
/* Builtin functions */
double sqrt(), cos(), sin(), atan();
/* Local variables */
static doublereal sfac, thet, zphs;
extern /* Subroutine */ int gwave_(), intrp_();
static doublecomplex er, et;
static doublereal rk, xt, yt, zt, r2s, cph;
static doublecomplex eph, erh, hrh, ezh;
static doublereal rho, sph;
static doublecomplex erv;
static doublereal rhs;
static doublecomplex hrv, ezv;
static doublereal rhx;
static doublecomplex hzv;
static doublereal rhy, phx, phy;
/* *** */
/* SFLDX RETURNS THE FIELD DUE TO GROUND FOR A CURRENT ELEMENT ON */
/* THE SOURCE SEGMENT AT T RELATIVE TO THE SEGMENT CENTER. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< COMMON /INCOM/ XO, YO, ZO, SN, XSN, YSN, ISNOR >*/
/*< COMMON /GWAV/ U, U2, XX1, XX2, R1, R2, ZMH, ZPH >*/
/*< >*/
/*< DIMENSION E(9) >*/
/*< >*/
/* Parameter adjustments */
--e;
/* Function Body */
/*< XT= XJ+ T* CABJ >*/
xt = dataj_1.xj + *t * dataj_1.cabj;
/*< YT= YJ+ T* SABJ >*/
yt = dataj_1.yj + *t * dataj_1.sabj;
/*< ZT= ZJ+ T* SALPJ >*/
zt = dataj_1.zj + *t * dataj_1.salpj;
/*< RHX= XO- XT >*/
rhx = incom_1.xo - xt;
/*< RHY= YO- YT >*/
rhy = incom_1.yo - yt;
/*< RHS= RHX* RHX+ RHY* RHY >*/
rhs = rhx * rhx + rhy * rhy;
/*< RHO= SQRT( RHS) >*/
rho = sqrt(rhs);
/*< IF( RHO.GT.0.) GOTO 1 >*/
if (rho > 0.) {
goto L1;
}
/*< RHX=1. >*/
rhx = 1.;
/*< RHY=0. >*/
rhy = 0.;
/*< PHX=0. >*/
phx = 0.;
/*< PHY=1. >*/
phy = 1.;
/*< GOTO 2 >*/
goto L2;
/*< 1 RHX= RHX/ RHO >*/
L1:
rhx /= rho;
/*< RHY= RHY/ RHO >*/
rhy /= rho;
/*< PHX=- RHY >*/
phx = -rhy;
/*< PHY= RHX >*/
phy = rhx;
/*< 2 CPH= RHX* XSN+ RHY* YSN >*/
L2:
cph = rhx * incom_1.xsn + rhy * incom_1.ysn;
/*< SPH= RHY* XSN- RHX* YSN >*/
sph = rhy * incom_1.xsn - rhx * incom_1.ysn;
/*< IF( ABS( CPH).LT.1.D-10) CPH=0. >*/
if (abs(cph) < 1e-10) {
cph = 0.;
}
/*< IF( ABS( SPH).LT.1.D-10) SPH=0. >*/
if (abs(sph) < 1e-10) {
sph = 0.;
}
/*< ZPH= ZO+ ZT >*/
gwav_1.zph = incom_1.zo + zt;
/*< ZPHS= ZPH* ZPH >*/
zphs = gwav_1.zph * gwav_1.zph;
/*< R2S= RHS+ ZPHS >*/
r2s = rhs + zphs;
/*< R2= SQRT( R2S) >*/
gwav_1.r2 = sqrt(r2s);
/*< RK= R2* TP >*/
rk = gwav_1.r2 * tp;
/*< XX2= CMPLX( COS( RK),- SIN( RK)) >*/
d__1 = cos(rk);
d__2 = -sin(rk);
z__1.r = d__1, z__1.i = d__2;
gwav_1.xx2.r = z__1.r, gwav_1.xx2.i = z__1.i;
/* USE NORTON APPROXIMATION FOR FIELD DUE TO GROUND. CURRENT IS */
/* LUMPED AT SEGMENT CENTER WITH CURRENT MOMENT FOR CONSTANT, SINE, */
/* OR COSINE DISTRIBUTION. */
/*< IF( ISNOR.EQ.1) GOTO 3 >*/
if (incom_1.isnor == 1) {
goto L3;
}
/*< ZMH=1. >*/
gwav_1.zmh = 1.;
/*< R1=1. >*/
gwav_1.r1 = 1.;
/*< XX1=0. >*/
gwav_1.xx1.r = 0., gwav_1.xx1.i = 0.;
/*< CALL GWAVE( ERV, EZV, ERH, EZH, EPH) >*/
gwave_(&erv, &ezv, &erh, &ezh, &eph);
/*< ET=-(0.,4.77134)* FRATI* XX2/( R2S* R2) >*/
z__3.r = gnd_1.frati.r * 0. - gnd_1.frati.i * -4.77134, z__3.i =
gnd_1.frati.r * -4.77134 + gnd_1.frati.i * 0.;
z__2.r = z__3.r * gwav_1.xx2.r - z__3.i * gwav_1.xx2.i, z__2.i = z__3.r *
gwav_1.xx2.i + z__3.i * gwav_1.xx2.r;
d__1 = r2s * gwav_1.r2;
z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1;
et.r = z__1.r, et.i = z__1.i;
/*< ER=2.* ET* CMPLX(1.0, RK) >*/
z__2.r = et.r * 2., z__2.i = et.i * 2.;
z__3.r = 1., z__3.i = rk;
z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i +
z__2.i * z__3.r;
er.r = z__1.r, er.i = z__1.i;
/*< ET= ET* CMPLX(1.0 - RK* RK, RK) >*/
d__1 = 1. - rk * rk;
z__2.r = d__1, z__2.i = rk;
z__1.r = et.r * z__2.r - et.i * z__2.i, z__1.i = et.r * z__2.i + et.i *
z__2.r;
et.r = z__1.r, et.i = z__1.i;
/*< HRV=( ER+ ET)* RHO* ZPH/ R2S >*/
z__4.r = er.r + et.r, z__4.i = er.i + et.i;
z__3.r = rho * z__4.r, z__3.i = rho * z__4.i;
z__2.r = gwav_1.zph * z__3.r, z__2.i = gwav_1.zph * z__3.i;
z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
hrv.r = z__1.r, hrv.i = z__1.i;
/*< HZV=( ZPHS* ER- RHS* ET)/ R2S >*/
z__3.r = zphs * er.r, z__3.i = zphs * er.i;
z__4.r = rhs * et.r, z__4.i = rhs * et.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
hzv.r = z__1.r, hzv.i = z__1.i;
/*< HRH=( RHS* ER- ZPHS* ET)/ R2S >*/
z__3.r = rhs * er.r, z__3.i = rhs * er.i;
z__4.r = zphs * et.r, z__4.i = zphs * et.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = z__2.r / r2s, z__1.i = z__2.i / r2s;
hrh.r = z__1.r, hrh.i = z__1.i;
/*< ERV= ERV- HRV >*/
z__1.r = erv.r - hrv.r, z__1.i = erv.i - hrv.i;
erv.r = z__1.r, erv.i = z__1.i;
/*< EZV= EZV- HZV >*/
z__1.r = ezv.r - hzv.r, z__1.i = ezv.i - hzv.i;
ezv.r = z__1.r, ezv.i = z__1.i;
/*< ERH= ERH+ HRH >*/
z__1.r = erh.r + hrh.r, z__1.i = erh.i + hrh.i;
erh.r = z__1.r, erh.i = z__1.i;
/*< EZH= EZH+ HRV >*/
z__1.r = ezh.r + hrv.r, z__1.i = ezh.i + hrv.i;
ezh.r = z__1.r, ezh.i = z__1.i;
/*< EPH= EPH+ ET >*/
z__1.r = eph.r + et.r, z__1.i = eph.i + et.i;
eph.r = z__1.r, eph.i = z__1.i;
/*< ERV= ERV* SALPJ >*/
z__1.r = dataj_1.salpj * erv.r, z__1.i = dataj_1.salpj * erv.i;
erv.r = z__1.r, erv.i = z__1.i;
/*< EZV= EZV* SALPJ >*/
z__1.r = dataj_1.salpj * ezv.r, z__1.i = dataj_1.salpj * ezv.i;
ezv.r = z__1.r, ezv.i = z__1.i;
/*< ERH= ERH* SN* CPH >*/
z__2.r = incom_1.sn * erh.r, z__2.i = incom_1.sn * erh.i;
z__1.r = cph * z__2.r, z__1.i = cph * z__2.i;
erh.r = z__1.r, erh.i = z__1.i;
/*< EZH= EZH* SN* CPH >*/
z__2.r = incom_1.sn * ezh.r, z__2.i = incom_1.sn * ezh.i;
z__1.r = cph * z__2.r, z__1.i = cph * z__2.i;
ezh.r = z__1.r, ezh.i = z__1.i;
/*< EPH= EPH* SN* SPH >*/
z__2.r = incom_1.sn * eph.r, z__2.i = incom_1.sn * eph.i;
z__1.r = sph * z__2.r, z__1.i = sph * z__2.i;
eph.r = z__1.r, eph.i = z__1.i;
/*< ERH= ERV+ ERH >*/
z__1.r = erv.r + erh.r, z__1.i = erv.i + erh.i;
erh.r = z__1.r, erh.i = z__1.i;
/*< E(1)=( ERH* RHX+ EPH* PHX)* S >*/
z__3.r = rhx * erh.r, z__3.i = rhx * erh.i;
z__4.r = phx * eph.r, z__4.i = phx * eph.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
e[1].r = z__1.r, e[1].i = z__1.i;
/*< E(2)=( ERH* RHY+ EPH* PHY)* S >*/
z__3.r = rhy * erh.r, z__3.i = rhy * erh.i;
z__4.r = phy * eph.r, z__4.i = phy * eph.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
e[2].r = z__1.r, e[2].i = z__1.i;
/*< E(3)=( EZV+ EZH)* S >*/
z__2.r = ezv.r + ezh.r, z__2.i = ezv.i + ezh.i;
z__1.r = dataj_1.s * z__2.r, z__1.i = dataj_1.s * z__2.i;
e[3].r = z__1.r, e[3].i = z__1.i;
/*< E(4)=0. >*/
e[4].r = 0., e[4].i = 0.;
/*< E(5)=0. >*/
e[5].r = 0., e[5].i = 0.;
/*< E(6)=0. >*/
e[6].r = 0., e[6].i = 0.;
/*< SFAC= PI* S >*/
sfac = pi * dataj_1.s;
/*< SFAC= SIN( SFAC)/ SFAC >*/
sfac = sin(sfac) / sfac;
/*< E(7)= E(1)* SFAC >*/
z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
e[7].r = z__1.r, e[7].i = z__1.i;
/*< E(8)= E(2)* SFAC >*/
z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
e[8].r = z__1.r, e[8].i = z__1.i;
/*< E(9)= E(3)* SFAC >*/
z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
e[9].r = z__1.r, e[9].i = z__1.i;
/* INTERPOLATE IN SOMMERFELD FIELD TABLES */
/*< RETURN >*/
return 0;
/*< 3 IF( RHO.LT.1.D-12) GOTO 4 >*/
L3:
if (rho < 1e-12) {
goto L4;
}
/*< THET= ATAN( ZPH/ RHO) >*/
thet = atan(gwav_1.zph / rho);
/*< GOTO 5 >*/
goto L5;
/*< 4 THET= POT >*/
L4:
thet = pot;
/* COMBINE VERTICAL AND HORIZONTAL COMPONENTS AND CONVERT TO X,Y,Z */
/* COMPONENTS. MULTIPLY BY EXP(-JKR)/R. */
/*< 5 CALL INTRP( R2, THET, ERV, EZV, ERH, EPH) >*/
L5:
intrp_(&gwav_1.r2, &thet, &erv, &ezv, &erh, &eph);
/*< XX2= XX2/ R2 >*/
z__1.r = gwav_1.xx2.r / gwav_1.r2, z__1.i = gwav_1.xx2.i / gwav_1.r2;
gwav_1.xx2.r = z__1.r, gwav_1.xx2.i = z__1.i;
/*< SFAC= SN* CPH >*/
sfac = incom_1.sn * cph;
/*< ERH= XX2*( SALPJ* ERV+ SFAC* ERH) >*/
z__3.r = dataj_1.salpj * erv.r, z__3.i = dataj_1.salpj * erv.i;
z__4.r = sfac * erh.r, z__4.i = sfac * erh.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__1.r = gwav_1.xx2.r * z__2.r - gwav_1.xx2.i * z__2.i, z__1.i =
gwav_1.xx2.r * z__2.i + gwav_1.xx2.i * z__2.r;
erh.r = z__1.r, erh.i = z__1.i;
/*< EZH= XX2*( SALPJ* EZV- SFAC* ERV) >*/
z__3.r = dataj_1.salpj * ezv.r, z__3.i = dataj_1.salpj * ezv.i;
z__4.r = sfac * erv.r, z__4.i = sfac * erv.i;
z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i;
z__1.r = gwav_1.xx2.r * z__2.r - gwav_1.xx2.i * z__2.i, z__1.i =
gwav_1.xx2.r * z__2.i + gwav_1.xx2.i * z__2.r;
ezh.r = z__1.r, ezh.i = z__1.i;
/* X,Y,Z FIELDS FOR CONSTANT CURRENT */
/*< EPH= SN* SPH* XX2* EPH >*/
d__1 = incom_1.sn * sph;
z__2.r = d__1 * gwav_1.xx2.r, z__2.i = d__1 * gwav_1.xx2.i;
z__1.r = z__2.r * eph.r - z__2.i * eph.i, z__1.i = z__2.r * eph.i +
z__2.i * eph.r;
eph.r = z__1.r, eph.i = z__1.i;
/*< E(1)= ERH* RHX+ EPH* PHX >*/
z__2.r = rhx * erh.r, z__2.i = rhx * erh.i;
z__3.r = phx * eph.r, z__3.i = phx * eph.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
e[1].r = z__1.r, e[1].i = z__1.i;
/*< E(2)= ERH* RHY+ EPH* PHY >*/
z__2.r = rhy * erh.r, z__2.i = rhy * erh.i;
z__3.r = phy * eph.r, z__3.i = phy * eph.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
e[2].r = z__1.r, e[2].i = z__1.i;
/*< E(3)= EZH >*/
e[3].r = ezh.r, e[3].i = ezh.i;
/* X,Y,Z FIELDS FOR SINE CURRENT */
/*< RK= TP* T >*/
rk = tp * *t;
/*< SFAC= SIN( RK) >*/
sfac = sin(rk);
/*< E(4)= E(1)* SFAC >*/
z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
e[4].r = z__1.r, e[4].i = z__1.i;
/*< E(5)= E(2)* SFAC >*/
z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
e[5].r = z__1.r, e[5].i = z__1.i;
/* X,Y,Z FIELDS FOR COSINE CURRENT */
/*< E(6)= E(3)* SFAC >*/
z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
e[6].r = z__1.r, e[6].i = z__1.i;
/*< SFAC= COS( RK) >*/
sfac = cos(rk);
/*< E(7)= E(1)* SFAC >*/
z__1.r = sfac * e[1].r, z__1.i = sfac * e[1].i;
e[7].r = z__1.r, e[7].i = z__1.i;
/*< E(8)= E(2)* SFAC >*/
z__1.r = sfac * e[2].r, z__1.i = sfac * e[2].i;
e[8].r = z__1.r, e[8].i = z__1.i;
/*< E(9)= E(3)* SFAC >*/
z__1.r = sfac * e[3].r, z__1.i = sfac * e[3].i;
e[9].r = z__1.r, e[9].i = z__1.i;
/*< RETURN >*/
return 0;
/*< END >*/
} /* sflds_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int solgf_(a, b, c, d, xy, ip, np, n1, n, mp, m1, m, n1c,
n2c, n2cz)
doublecomplex *a, *b, *c, *d, *xy;
integer *ip, *np, *n1, *n, *mp, *m1, *m, *n1c, *n2c, *n2cz;
{
/* System generated locals */
integer b_dim1, b_offset, c_dim1, c_offset, d_dim1, d_offset, i__1, i__2,
i__3, i__4, i__5;
doublecomplex z__1, z__2;
alist al__1;
/* Builtin functions */
integer s_rsue(), do_uio(), e_rsue(), f_rew();
/* Local variables */
static integer neqs, i, j, icass;
extern /* Subroutine */ int solve_();
static integer n2, nlsys, npsys, ii, jj, ni, jp, nblsys;
extern /* Subroutine */ int solves_(), ltsolv_();
static integer ifl, npb, neq, npm;
static doublecomplex sum;
/* Fortran I/O blocks */
static cilist io___2027 = { 0, 15, 0, 0, 0 };
static cilist io___2030 = { 0, 11, 0, 0, 0 };
static cilist io___2035 = { 0, 14, 0, 0, 0 };
/* *** */
/* SOLVE FOR CURRENT IN N.G.F. PROCEDURE */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, B, C, D, SUM, XY, Y >*/
/*< COMMON /SCRATM/ Y( N2M) >*/
/*< >*/
/*< >*/
/*< DIMENSION A(1), B( N1C,1), C( N1C,1), D( N2CZ,1), IP(1), XY(1) >*/
/*< IFL=14 >*/
/* Parameter adjustments */
--ip;
--xy;
d_dim1 = *n2cz;
d_offset = d_dim1 + 1;
d -= d_offset;
c_dim1 = *n1c;
c_offset = c_dim1 + 1;
c -= c_offset;
b_dim1 = *n1c;
b_offset = b_dim1 + 1;
b -= b_offset;
--a;
/* Function Body */
ifl = 14;
/*< IF( ICASX.GT.0) IFL=13 >*/
if (matpar_1.icasx > 0) {
ifl = 13;
}
/* NORMAL SOLUTION. NOT N.G.F. */
/*< IF( N2C.GT.0) GOTO 1 >*/
if (*n2c > 0) {
goto L1;
}
/*< CALL SOLVES( A, IP, XY, N1C,1, NP, N, MP, M,13, IFL) >*/
solves_(&a[1], &ip[1], &xy[1], n1c, &c__1, np, n, mp, m, &c__13, &ifl);
/*< GOTO 22 >*/
goto L22;
/* REORDER EXCITATION ARRAY */
/*< 1 IF( N1.EQ. N.OR. M1.EQ.0) GOTO 5 >*/
L1:
if (*n1 == *n || *m1 == 0) {
goto L5;
}
/*< N2= N1+1 >*/
n2 = *n1 + 1;
/*< JJ= N+1 >*/
jj = *n + 1;
/*< NPM= N+2* M1 >*/
npm = *n + (*m1 << 1);
/*< DO 2 I= N2, NPM >*/
i__1 = npm;
for (i = n2; i <= i__1; ++i) {
/*< 2 Y( I)= XY( I) >*/
/* L2: */
i__2 = i - 1;
i__3 = i;
scratm_2.y[i__2].r = xy[i__3].r, scratm_2.y[i__2].i = xy[i__3].i;
}
/*< J= N1 >*/
j = *n1;
/*< DO 3 I= JJ, NPM >*/
i__2 = npm;
for (i = jj; i <= i__2; ++i) {
/*< J= J+1 >*/
++j;
/*< 3 XY( J)= Y( I) >*/
/* L3: */
i__3 = j;
i__1 = i - 1;
xy[i__3].r = scratm_2.y[i__1].r, xy[i__3].i = scratm_2.y[i__1].i;
}
/*< DO 4 I= N2, N >*/
i__3 = *n;
for (i = n2; i <= i__3; ++i) {
/*< J= J+1 >*/
++j;
/*< 4 XY( J)= Y( I) >*/
/* L4: */
i__1 = j;
i__2 = i - 1;
xy[i__1].r = scratm_2.y[i__2].r, xy[i__1].i = scratm_2.y[i__2].i;
}
/*< 5 NEQS= NSCON+2* NPCON >*/
L5:
neqs = segj_1.nscon + (segj_1.npcon << 1);
/*< IF( NEQS.EQ.0) GOTO 7 >*/
if (neqs == 0) {
goto L7;
}
/*< NEQ= N1C+ N2C >*/
neq = *n1c + *n2c;
/* COMPUTE INV(A)E1 */
/*< NEQS= NEQ- NEQS+1 >*/
neqs = neq - neqs + 1;
/*< DO 6 I= NEQS, NEQ >*/
i__1 = neq;
for (i = neqs; i <= i__1; ++i) {
/*< 6 XY( I)=(0.,0.) >*/
/* L6: */
i__2 = i;
xy[i__2].r = 0., xy[i__2].i = 0.;
}
/*< 7 CALL SOLVES( A, IP, XY, N1C,1, NP, N1, MP, M1,13, IFL) >*/
L7:
solves_(&a[1], &ip[1], &xy[1], n1c, &c__1, np, n1, mp, m1, &c__13, &ifl);
/*< NI=0 >*/
ni = 0;
/* COMPUTE E2-C(INV(A)E1) */
/*< NPB= NPBL >*/
npb = matpar_1.npbl;
/*< DO 10 JJ=1, NBBL >*/
i__2 = matpar_1.nbbl;
for (jj = 1; jj <= i__2; ++jj) {
/*< IF( JJ.EQ. NBBL) NPB= NLBL >*/
if (jj == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< IF( ICASX.GT.1) READ( 15) (( C( I, J), I=1, N1C), J=1, NPB) >*/
if (matpar_1.icasx > 1) {
s_rsue(&io___2027);
i__1 = npb;
for (j = 1; j <= i__1; ++j) {
i__3 = *n1c;
for (i = 1; i <= i__3; ++i) {
do_uio(&c__2, (char *)&c[i + j * c_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_rsue();
}
/*< II= N1C+ NI >*/
ii = *n1c + ni;
/*< DO 9 I=1, NPB >*/
i__3 = npb;
for (i = 1; i <= i__3; ++i) {
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< DO 8 J=1, N1C >*/
i__1 = *n1c;
for (j = 1; j <= i__1; ++j) {
/*< 8 SUM= SUM+ C( J, I)* XY( J) >*/
/* L8: */
i__4 = j + i * c_dim1;
i__5 = j;
z__2.r = c[i__4].r * xy[i__5].r - c[i__4].i * xy[i__5].i,
z__2.i = c[i__4].r * xy[i__5].i + c[i__4].i * xy[i__5]
.r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< J= II+ I >*/
j = ii + i;
/*< 9 XY( J)= XY( J)- SUM >*/
/* L9: */
i__4 = j;
i__5 = j;
z__1.r = xy[i__5].r - sum.r, z__1.i = xy[i__5].i - sum.i;
xy[i__4].r = z__1.r, xy[i__4].i = z__1.i;
}
/*< 10 NI= NI+ NPBL >*/
/* L10: */
ni += matpar_1.npbl;
}
/*< REWIND 15 >*/
al__1.aerr = 0;
al__1.aunit = 15;
f_rew(&al__1);
/* COMPUTE INV(D)(E2-C(INV(A)E1)) = I2 */
/*< JJ= N1C+1 >*/
jj = *n1c + 1;
/*< IF( ICASX.GT.1) GOTO 11 >*/
if (matpar_1.icasx > 1) {
goto L11;
}
/*< CALL SOLVE( N2C, D, IP( JJ), XY( JJ), N2C) >*/
solve_(n2c, &d[d_offset], &ip[jj], &xy[jj], n2c);
/*< GOTO 13 >*/
goto L13;
/*< 11 IF( ICASX.EQ.4) GOTO 12 >*/
L11:
if (matpar_1.icasx == 4) {
goto L12;
}
/*< NI= N2C* N2C >*/
ni = *n2c * *n2c;
/*< READ( 11) ( B( J,1), J=1, NI) >*/
s_rsue(&io___2030);
i__2 = ni;
for (j = 1; j <= i__2; ++j) {
do_uio(&c__2, (char *)&b[j + b_dim1], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< CALL SOLVE( N2C, B, IP( JJ), XY( JJ), N2C) >*/
solve_(n2c, &b[b_offset], &ip[jj], &xy[jj], n2c);
/*< GOTO 13 >*/
goto L13;
/*< 12 NBLSYS= NBLSYM >*/
L12:
nblsys = matpar_1.nblsym;
/*< NPSYS= NPSYM >*/
npsys = matpar_1.npsym;
/*< NLSYS= NLSYM >*/
nlsys = matpar_1.nlsym;
/*< ICASS= ICASE >*/
icass = matpar_1.icase;
/*< NBLSYM= NBBL >*/
matpar_1.nblsym = matpar_1.nbbl;
/*< NPSYM= NPBL >*/
matpar_1.npsym = matpar_1.npbl;
/*< NLSYM= NLBL >*/
matpar_1.nlsym = matpar_1.nlbl;
/*< ICASE=3 >*/
matpar_1.icase = 3;
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< REWIND 16 >*/
al__1.aerr = 0;
al__1.aunit = 16;
f_rew(&al__1);
/*< CALL LTSOLV( B, N2C, IP( JJ), XY( JJ), N2C,1,11,16) >*/
ltsolv_(&b[b_offset], n2c, &ip[jj], &xy[jj], n2c, &c__1, &c__11, &c__16);
/*< REWIND 11 >*/
al__1.aerr = 0;
al__1.aunit = 11;
f_rew(&al__1);
/*< REWIND 16 >*/
al__1.aerr = 0;
al__1.aunit = 16;
f_rew(&al__1);
/*< NBLSYM= NBLSYS >*/
matpar_1.nblsym = nblsys;
/*< NPSYM= NPSYS >*/
matpar_1.npsym = npsys;
/*< NLSYM= NLSYS >*/
matpar_1.nlsym = nlsys;
/*< ICASE= ICASS >*/
matpar_1.icase = icass;
/*< 13 NI=0 >*/
L13:
ni = 0;
/* COMPUTE INV(A)E1-(INV(A)B)I2 = I1 */
/*< NPB= NPBL >*/
npb = matpar_1.npbl;
/*< DO 16 JJ=1, NBBL >*/
i__2 = matpar_1.nbbl;
for (jj = 1; jj <= i__2; ++jj) {
/*< IF( JJ.EQ. NBBL) NPB= NLBL >*/
if (jj == matpar_1.nbbl) {
npb = matpar_1.nlbl;
}
/*< IF( ICASX.GT.1) READ( 14) (( B( I, J), I=1, N1C), J=1, NPB) >*/
if (matpar_1.icasx > 1) {
s_rsue(&io___2035);
i__4 = npb;
for (j = 1; j <= i__4; ++j) {
i__5 = *n1c;
for (i = 1; i <= i__5; ++i) {
do_uio(&c__2, (char *)&b[i + j * b_dim1], (ftnlen)sizeof(
doublereal));
}
}
e_rsue();
}
/*< II= N1C+ NI >*/
ii = *n1c + ni;
/*< DO 15 I=1, N1C >*/
i__5 = *n1c;
for (i = 1; i <= i__5; ++i) {
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< DO 14 J=1, NPB >*/
i__4 = npb;
for (j = 1; j <= i__4; ++j) {
/*< JP= II+ J >*/
jp = ii + j;
/*< 14 SUM= SUM+ B( I, J)* XY( JP) >*/
/* L14: */
i__3 = i + j * b_dim1;
i__1 = jp;
z__2.r = b[i__3].r * xy[i__1].r - b[i__3].i * xy[i__1].i,
z__2.i = b[i__3].r * xy[i__1].i + b[i__3].i * xy[i__1]
.r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< 15 XY( I)= XY( I)- SUM >*/
/* L15: */
i__3 = i;
i__1 = i;
z__1.r = xy[i__1].r - sum.r, z__1.i = xy[i__1].i - sum.i;
xy[i__3].r = z__1.r, xy[i__3].i = z__1.i;
}
/*< 16 NI= NI+ NPBL >*/
/* L16: */
ni += matpar_1.npbl;
}
/*< REWIND 14 >*/
al__1.aerr = 0;
al__1.aunit = 14;
f_rew(&al__1);
/* REORDER CURRENT ARRAY */
/*< IF( N1.EQ. N.OR. M1.EQ.0) GOTO 20 >*/
if (*n1 == *n || *m1 == 0) {
goto L20;
}
/*< DO 17 I= N2, NPM >*/
i__2 = npm;
for (i = n2; i <= i__2; ++i) {
/*< 17 Y( I)= XY( I) >*/
/* L17: */
i__3 = i - 1;
i__1 = i;
scratm_2.y[i__3].r = xy[i__1].r, scratm_2.y[i__3].i = xy[i__1].i;
}
/*< JJ= N1C+1 >*/
jj = *n1c + 1;
/*< J= N1 >*/
j = *n1;
/*< DO 18 I= JJ, NPM >*/
i__3 = npm;
for (i = jj; i <= i__3; ++i) {
/*< J= J+1 >*/
++j;
/*< 18 XY( J)= Y( I) >*/
/* L18: */
i__1 = j;
i__2 = i - 1;
xy[i__1].r = scratm_2.y[i__2].r, xy[i__1].i = scratm_2.y[i__2].i;
}
/*< DO 19 I= N2, N1C >*/
i__1 = *n1c;
for (i = n2; i <= i__1; ++i) {
/*< J= J+1 >*/
++j;
/*< 19 XY( J)= Y( I) >*/
/* L19: */
i__2 = j;
i__3 = i - 1;
xy[i__2].r = scratm_2.y[i__3].r, xy[i__2].i = scratm_2.y[i__3].i;
}
/*< 20 IF( NSCON.EQ.0) GOTO 22 >*/
L20:
if (segj_1.nscon == 0) {
goto L22;
}
/*< J= NEQS-1 >*/
j = neqs - 1;
/*< DO 21 I=1, NSCON >*/
i__2 = segj_1.nscon;
for (i = 1; i <= i__2; ++i) {
/*< J= J+1 >*/
++j;
/*< JJ= ISCON( I) >*/
jj = segj_1.iscon[i - 1];
/*< 21 XY( JJ)= XY( J) >*/
/* L21: */
i__3 = jj;
i__1 = j;
xy[i__3].r = xy[i__1].r, xy[i__3].i = xy[i__1].i;
}
/*< 22 RETURN >*/
L22:
return 0;
/*< END >*/
} /* solgf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE SOLVE( N, A, IP, B, NDIM) >*/
/* Subroutine */ int solve_(n, a, ip, b, ndim)
integer *n;
doublecomplex *a;
integer *ip;
doublecomplex *b;
integer *ndim;
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2;
/* Builtin functions */
void z_div();
/* Local variables */
static integer i, j, k, pi, ip1;
static doublecomplex sum;
/* *** */
/* SUBROUTINE TO SOLVE THE MATRIX EQUATION LU*X=B WHERE L IS A UNIT */
/* LOWER TRIANGULAR MATRIX AND U IS AN UPPER TRIANGULAR MATRIX BOTH */
/* OF WHICH ARE STORED IN A. THE RHS VECTOR B IS INPUT AND THE */
/* SOLUTION IS RETURNED THROUGH VECTOR B. (MATRIX TRANSPOSED. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, B, Y, SUM >*/
/*< INTEGER PI >*/
/*< COMMON /SCRATM/ Y( N2M) >*/
/* FORWARD SUBSTITUTION */
/*< DIMENSION A( NDIM, NDIM), IP( NDIM), B( NDIM) >*/
/*< DO 3 I=1, N >*/
/* Parameter adjustments */
--b;
--ip;
a_dim1 = *ndim;
a_offset = a_dim1 + 1;
a -= a_offset;
/* Function Body */
i__1 = *n;
for (i = 1; i <= i__1; ++i) {
/*< PI= IP( I) >*/
pi = ip[i];
/*< Y( I)= B( PI) >*/
i__2 = i - 1;
i__3 = pi;
scratm_2.y[i__2].r = b[i__3].r, scratm_2.y[i__2].i = b[i__3].i;
/*< B( PI)= B( I) >*/
i__2 = pi;
i__3 = i;
b[i__2].r = b[i__3].r, b[i__2].i = b[i__3].i;
/*< IP1= I+1 >*/
ip1 = i + 1;
/*< IF( IP1.GT. N) GOTO 2 >*/
if (ip1 > *n) {
goto L2;
}
/*< DO 1 J= IP1, N >*/
i__2 = *n;
for (j = ip1; j <= i__2; ++j) {
/*< B( J)= B( J)- A( I, J)* Y( I) >*/
i__3 = j;
i__4 = j;
i__5 = i + j * a_dim1;
i__6 = i - 1;
z__2.r = a[i__5].r * scratm_2.y[i__6].r - a[i__5].i * scratm_2.y[
i__6].i, z__2.i = a[i__5].r * scratm_2.y[i__6].i + a[i__5]
.i * scratm_2.y[i__6].r;
z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i;
b[i__3].r = z__1.r, b[i__3].i = z__1.i;
/*< 1 CONTINUE >*/
/* L1: */
}
/*< 2 CONTINUE >*/
L2:
/* BACKWARD SUBSTITUTION */
/*< 3 CONTINUE >*/
/* L3: */
;
}
/*< DO 6 K=1, N >*/
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
/*< I= N- K+1 >*/
i = *n - k + 1;
/*< SUM=(0.,0.) >*/
sum.r = 0., sum.i = 0.;
/*< IP1= I+1 >*/
ip1 = i + 1;
/*< IF( IP1.GT. N) GOTO 5 >*/
if (ip1 > *n) {
goto L5;
}
/*< DO 4 J= IP1, N >*/
i__2 = *n;
for (j = ip1; j <= i__2; ++j) {
/*< SUM= SUM+ A( J, I)* B( J) >*/
i__3 = j + i * a_dim1;
i__4 = j;
z__2.r = a[i__3].r * b[i__4].r - a[i__3].i * b[i__4].i, z__2.i =
a[i__3].r * b[i__4].i + a[i__3].i * b[i__4].r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
/*< 4 CONTINUE >*/
/* L4: */
}
/*< 5 CONTINUE >*/
L5:
/*< B( I)=( Y( I)- SUM)/ A( I, I) >*/
i__2 = i;
i__3 = i - 1;
z__2.r = scratm_2.y[i__3].r - sum.r, z__2.i = scratm_2.y[i__3].i -
sum.i;
z_div(&z__1, &z__2, &a[i + i * a_dim1]);
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/*< 6 CONTINUE >*/
/* L6: */
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* solve_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE SOLVES( A, IP, B, NEQ, NRH, NP, N, MP, M, IFL1, IFL2) >*/
/* Subroutine */ int solves_(a, ip, b, neq, nrh, np, n, mp, m, ifl1, ifl2)
doublecomplex *a;
integer *ip;
doublecomplex *b;
integer *neq, *nrh, *np, *n, *mp, *m, *ifl1, *ifl2;
{
/* System generated locals */
integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6;
doublecomplex z__1, z__2, z__3;
alist al__1;
/* Builtin functions */
void d_cnjg();
integer f_rew(), s_rsue(), do_uio(), e_rsue();
/* Local variables */
static doublereal fnop;
static integer npeq, nrow, i, j, k;
static doublereal fnorm;
extern /* Subroutine */ int solve_();
static integer ia, ib, ic, kk;
extern /* Subroutine */ int ltsolv_();
static integer nop;
static doublecomplex sum;
/* Fortran I/O blocks */
static cilist io___2056 = { 0, 0, 0, 0, 0 };
/* *** */
/* SUBROUTINE SOLVES, FOR SYMMETRIC STRUCTURES, HANDLES THE */
/* TRANSFORMATION OF THE RIGHT HAND SIDE VECTOR AND SOLUTION OF THE */
/* MATRIX EQ. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< COMPLEX A, B, Y, SUM, SSX >*/
/*< COMMON /SMAT/ SSX(16,16) >*/
/*< COMMON /SCRATM/ Y( N2M) >*/
/*< >*/
/*< DIMENSION A(1), IP(1), B( NEQ, NRH) >*/
/*< NPEQ= NP+2* MP >*/
/* Parameter adjustments */
b_dim1 = *neq;
b_offset = b_dim1 + 1;
b -= b_offset;
--ip;
--a;
/* Function Body */
npeq = *np + (*mp << 1);
/*< NOP= NEQ/ NPEQ >*/
nop = *neq / npeq;
/*< FNOP= NOP >*/
fnop = (doublereal) nop;
/*< FNORM=1./ FNOP >*/
fnorm = 1. / fnop;
/*< NROW= NEQ >*/
nrow = *neq;
/*< IF( ICASE.GT.3) NROW= NPEQ >*/
if (matpar_1.icase > 3) {
nrow = npeq;
}
/*< IF( NOP.EQ.1) GOTO 11 >*/
if (nop == 1) {
goto L11;
}
/*< DO 10 IC=1, NRH >*/
i__1 = *nrh;
for (ic = 1; ic <= i__1; ++ic) {
/*< IF( N.EQ.0.OR. M.EQ.0) GOTO 6 >*/
if (*n == 0 || *m == 0) {
goto L6;
}
/*< DO 1 I=1, NEQ >*/
i__2 = *neq;
for (i = 1; i <= i__2; ++i) {
/*< 1 Y( I)= B( I, IC) >*/
/* L1: */
i__3 = i - 1;
i__4 = i + ic * b_dim1;
scratm_2.y[i__3].r = b[i__4].r, scratm_2.y[i__3].i = b[i__4].i;
}
/*< KK=2* MP >*/
kk = *mp << 1;
/*< IA= NP >*/
ia = *np;
/*< IB= N >*/
ib = *n;
/*< J= NP >*/
j = *np;
/*< DO 5 K=1, NOP >*/
i__3 = nop;
for (k = 1; k <= i__3; ++k) {
/*< IF( K.EQ.1) GOTO 3 >*/
if (k == 1) {
goto L3;
}
/*< DO 2 I=1, NP >*/
i__4 = *np;
for (i = 1; i <= i__4; ++i) {
/*< IA= IA+1 >*/
++ia;
/*< J= J+1 >*/
++j;
/*< 2 B( J, IC)= Y( IA) >*/
/* L2: */
i__2 = j + ic * b_dim1;
i__5 = ia - 1;
b[i__2].r = scratm_2.y[i__5].r, b[i__2].i = scratm_2.y[i__5]
.i;
}
/*< IF( K.EQ. NOP) GOTO 5 >*/
if (k == nop) {
goto L5;
}
/*< 3 DO 4 I=1, KK >*/
L3:
i__2 = kk;
for (i = 1; i <= i__2; ++i) {
/*< IB= IB+1 >*/
++ib;
/*< J= J+1 >*/
++j;
/*< 4 B( J, IC)= Y( IB) >*/
/* L4: */
i__5 = j + ic * b_dim1;
i__4 = ib - 1;
b[i__5].r = scratm_2.y[i__4].r, b[i__5].i = scratm_2.y[i__4]
.i;
}
/* TRANSFORM MATRIX EQ. RHS VECTOR ACCORDING TO SYMMETRY MODES
*/
/*< 5 CONTINUE >*/
L5:
;
}
/*< 6 DO 10 I=1, NPEQ >*/
L6:
i__3 = npeq;
for (i = 1; i <= i__3; ++i) {
/*< DO 7 K=1, NOP >*/
i__5 = nop;
for (k = 1; k <= i__5; ++k) {
/*< IA= I+( K-1)* NPEQ >*/
ia = i + (k - 1) * npeq;
/*< 7 Y( K)= B( IA, IC) >*/
/* L7: */
i__4 = k - 1;
i__2 = ia + ic * b_dim1;
scratm_2.y[i__4].r = b[i__2].r, scratm_2.y[i__4].i = b[i__2]
.i;
}
/*< SUM= Y(1) >*/
sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
/*< DO 8 K=2, NOP >*/
i__4 = nop;
for (k = 2; k <= i__4; ++k) {
/*< 8 SUM= SUM+ Y( K) >*/
/* L8: */
i__2 = k - 1;
z__1.r = sum.r + scratm_2.y[i__2].r, z__1.i = sum.i +
scratm_2.y[i__2].i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< B( I, IC)= SUM* FNORM >*/
i__2 = i + ic * b_dim1;
z__1.r = fnorm * sum.r, z__1.i = fnorm * sum.i;
b[i__2].r = z__1.r, b[i__2].i = z__1.i;
/*< DO 10 K=2, NOP >*/
i__2 = nop;
for (k = 2; k <= i__2; ++k) {
/*< IA= I+( K-1)* NPEQ >*/
ia = i + (k - 1) * npeq;
/*< SUM= Y(1) >*/
sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
/*< DO 9 J=2, NOP >*/
i__4 = nop;
for (j = 2; j <= i__4; ++j) {
/*< 9 SUM= SUM+ Y( J)* CONJG( SSX( K, J)) >*/
/* L9: */
i__5 = j - 1;
d_cnjg(&z__3, &smat_1.ssx[k + (j << 4) - 17]);
z__2.r = scratm_2.y[i__5].r * z__3.r - scratm_2.y[i__5].i
* z__3.i, z__2.i = scratm_2.y[i__5].r * z__3.i +
scratm_2.y[i__5].i * z__3.r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< 10 B( IA, IC)= SUM* FNORM >*/
/* L10: */
i__5 = ia + ic * b_dim1;
z__1.r = fnorm * sum.r, z__1.i = fnorm * sum.i;
b[i__5].r = z__1.r, b[i__5].i = z__1.i;
}
}
}
/*< 11 IF( ICASE.LT.3) GOTO 12 >*/
L11:
if (matpar_1.icase < 3) {
goto L12;
}
/*< REWIND IFL1 >*/
al__1.aerr = 0;
al__1.aunit = *ifl1;
f_rew(&al__1);
/* SOLVE EACH MODE EQUATION */
/*< REWIND IFL2 >*/
al__1.aerr = 0;
al__1.aunit = *ifl2;
f_rew(&al__1);
/*< 12 DO 16 KK=1, NOP >*/
L12:
i__5 = nop;
for (kk = 1; kk <= i__5; ++kk) {
/*< IA=( KK-1)* NPEQ+1 >*/
ia = (kk - 1) * npeq + 1;
/*< IB= IA >*/
ib = ia;
/*< IF( ICASE.NE.4) GOTO 13 >*/
if (matpar_1.icase != 4) {
goto L13;
}
/*< I= NPEQ* NPEQ >*/
i = npeq * npeq;
/*< READ( IFL1) ( A( J), J=1, I) >*/
io___2056.ciunit = *ifl1;
s_rsue(&io___2056);
i__2 = i;
for (j = 1; j <= i__2; ++j) {
do_uio(&c__2, (char *)&a[j], (ftnlen)sizeof(doublereal));
}
e_rsue();
/*< IB=1 >*/
ib = 1;
/*< 13 IF( ICASE.EQ.3.OR. ICASE.EQ.5) GOTO 15 >*/
L13:
if (matpar_1.icase == 3 || matpar_1.icase == 5) {
goto L15;
}
/*< DO 14 IC=1, NRH >*/
i__2 = *nrh;
for (ic = 1; ic <= i__2; ++ic) {
/*< 14 CALL SOLVE( NPEQ, A( IB), IP( IA), B( IA, IC), NROW) >*/
/* L14: */
solve_(&npeq, &a[ib], &ip[ia], &b[ia + ic * b_dim1], &nrow);
}
/*< GOTO 16 >*/
goto L16;
/*< 15 CALL LTSOLV( A, NPEQ, IP( IA), B( IA,1), NEQ, NRH, IFL1, IFL2) >*/
L15:
ltsolv_(&a[1], &npeq, &ip[ia], &b[ia + b_dim1], neq, nrh, ifl1, ifl2);
/*< 16 CONTINUE >*/
L16:
;
}
/* INVERSE TRANSFORM THE MODE SOLUTIONS */
/*< IF( NOP.EQ.1) RETURN >*/
if (nop == 1) {
return 0;
}
/*< DO 26 IC=1, NRH >*/
i__5 = *nrh;
for (ic = 1; ic <= i__5; ++ic) {
/*< DO 20 I=1, NPEQ >*/
i__2 = npeq;
for (i = 1; i <= i__2; ++i) {
/*< DO 17 K=1, NOP >*/
i__3 = nop;
for (k = 1; k <= i__3; ++k) {
/*< IA= I+( K-1)* NPEQ >*/
ia = i + (k - 1) * npeq;
/*< 17 Y( K)= B( IA, IC) >*/
/* L17: */
i__1 = k - 1;
i__4 = ia + ic * b_dim1;
scratm_2.y[i__1].r = b[i__4].r, scratm_2.y[i__1].i = b[i__4]
.i;
}
/*< SUM= Y(1) >*/
sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
/*< DO 18 K=2, NOP >*/
i__1 = nop;
for (k = 2; k <= i__1; ++k) {
/*< 18 SUM= SUM+ Y( K) >*/
/* L18: */
i__4 = k - 1;
z__1.r = sum.r + scratm_2.y[i__4].r, z__1.i = sum.i +
scratm_2.y[i__4].i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< B( I, IC)= SUM >*/
i__4 = i + ic * b_dim1;
b[i__4].r = sum.r, b[i__4].i = sum.i;
/*< DO 20 K=2, NOP >*/
i__4 = nop;
for (k = 2; k <= i__4; ++k) {
/*< IA= I+( K-1)* NPEQ >*/
ia = i + (k - 1) * npeq;
/*< SUM= Y(1) >*/
sum.r = scratm_2.y[0].r, sum.i = scratm_2.y[0].i;
/*< DO 19 J=2, NOP >*/
i__1 = nop;
for (j = 2; j <= i__1; ++j) {
/*< 19 SUM= SUM+ Y( J)* SSX( K, J) >*/
/* L19: */
i__3 = j - 1;
i__6 = k + (j << 4) - 17;
z__2.r = scratm_2.y[i__3].r * smat_1.ssx[i__6].r -
scratm_2.y[i__3].i * smat_1.ssx[i__6].i, z__2.i =
scratm_2.y[i__3].r * smat_1.ssx[i__6].i +
scratm_2.y[i__3].i * smat_1.ssx[i__6].r;
z__1.r = sum.r + z__2.r, z__1.i = sum.i + z__2.i;
sum.r = z__1.r, sum.i = z__1.i;
}
/*< 20 B( IA, IC)= SUM >*/
/* L20: */
i__3 = ia + ic * b_dim1;
b[i__3].r = sum.r, b[i__3].i = sum.i;
}
}
/*< IF( N.EQ.0.OR. M.EQ.0) GOTO 26 >*/
if (*n == 0 || *m == 0) {
goto L26;
}
/*< DO 21 I=1, NEQ >*/
i__3 = *neq;
for (i = 1; i <= i__3; ++i) {
/*< 21 Y( I)= B( I, IC) >*/
/* L21: */
i__4 = i - 1;
i__2 = i + ic * b_dim1;
scratm_2.y[i__4].r = b[i__2].r, scratm_2.y[i__4].i = b[i__2].i;
}
/*< KK=2* MP >*/
kk = *mp << 1;
/*< IA= NP >*/
ia = *np;
/*< IB= N >*/
ib = *n;
/*< J= NP >*/
j = *np;
/*< DO 25 K=1, NOP >*/
i__4 = nop;
for (k = 1; k <= i__4; ++k) {
/*< IF( K.EQ.1) GOTO 23 >*/
if (k == 1) {
goto L23;
}
/*< DO 22 I=1, NP >*/
i__2 = *np;
for (i = 1; i <= i__2; ++i) {
/*< IA= IA+1 >*/
++ia;
/*< J= J+1 >*/
++j;
/*< 22 B( IA, IC)= Y( J) >*/
/* L22: */
i__3 = ia + ic * b_dim1;
i__6 = j - 1;
b[i__3].r = scratm_2.y[i__6].r, b[i__3].i = scratm_2.y[i__6]
.i;
}
/*< IF( K.EQ. NOP) GOTO 25 >*/
if (k == nop) {
goto L25;
}
/*< 23 DO 24 I=1, KK >*/
L23:
i__3 = kk;
for (i = 1; i <= i__3; ++i) {
/*< IB= IB+1 >*/
++ib;
/*< J= J+1 >*/
++j;
/*< 24 B( IB, IC)= Y( J) >*/
/* L24: */
i__6 = ib + ic * b_dim1;
i__2 = j - 1;
b[i__6].r = scratm_2.y[i__2].r, b[i__6].i = scratm_2.y[i__2]
.i;
}
/*< 25 CONTINUE >*/
L25:
;
}
/*< 26 CONTINUE >*/
L26:
;
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* solves_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE TBF( I, ICAP) >*/
/* Subroutine */ int tbf_(i, icap)
integer *i, *icap;
{
/* Initialized data */
static doublereal pi = 3.141592654;
static integer jmax = 30;
/* Format strings */
static char fmt_29[] = "(\002 TBF - SEGMENT CONNECTION ERROR FOR SEGMEN\
T\002,i5)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double sin(), cos(), log();
integer s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer iend, jend, jcox, njun1, njun2;
static doublereal d;
static integer jsnop;
static doublereal cd, aj, ap, sd, pp, pm, qp, qm, cdh, sdh, omc, sig, xxi;
/* Fortran I/O blocks */
static cilist io___2079 = { 0, 6, 0, fmt_29, 0 };
/* *** */
/* COMPUTE BASIS FUNCTION I */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< DATA PI/3.141592654D+0/, JMAX/30/ >*/
/*< JSNO=0 >*/
segj_1.jsno = 0;
/*< PP=0. >*/
pp = 0.;
/*< JCOX= ICON1( I) >*/
jcox = data_1.icon1[*i - 1];
/*< IF( JCOX.GT.10000) JCOX= I >*/
if (jcox > 10000) {
jcox = *i;
}
/*< JEND=-1 >*/
jend = -1;
/*< IEND=-1 >*/
iend = -1;
/*< SIG=-1. >*/
sig = -1.;
/*< IF( JCOX) 1,10,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L10;
} else {
goto L2;
}
/*< 1 JCOX=- JCOX >*/
L1:
jcox = -jcox;
/*< GOTO 3 >*/
goto L3;
/*< 2 SIG=- SIG >*/
L2:
sig = -sig;
/*< JEND=- JEND >*/
jend = -jend;
/*< 3 JSNO= JSNO+1 >*/
L3:
++segj_1.jsno;
/*< IF( JSNO.GE. JMAX) GOTO 28 >*/
if (segj_1.jsno >= jmax) {
goto L28;
}
/*< JCO( JSNO)= JCOX >*/
segj_1.jco[segj_1.jsno - 1] = jcox;
/*< D= PI* SI( JCOX) >*/
d = pi * data_1.si[jcox - 1];
/*< SDH= SIN( D) >*/
sdh = sin(d);
/*< CDH= COS( D) >*/
cdh = cos(d);
/*< SD=2.* SDH* CDH >*/
d__1 = sdh * 2.;
sd = d__1 * cdh;
/*< IF( D.GT.0.015) GOTO 4 >*/
if (d > .015) {
goto L4;
}
/*< OMC=4.* D* D >*/
d__1 = d * 4.;
omc = d__1 * d;
/*< OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
/*< GOTO 5 >*/
goto L5;
/*< 4 OMC=1.- CDH* CDH+ SDH* SDH >*/
L4:
omc = 1. - cdh * cdh + sdh * sdh;
/*< 5 AJ=1./( LOG(1./( PI* BI( JCOX)))-.577215664D+0) >*/
L5:
aj = 1. / (log(1. / (pi * data_1.bi[jcox - 1])) - .577215664);
/*< PP= PP- OMC/ SD* AJ >*/
pp -= omc / sd * aj;
/*< AX( JSNO)= AJ/ SD* SIG >*/
segj_1.ax[segj_1.jsno - 1] = aj / sd * sig;
/*< BX( JSNO)= AJ/(2.* CDH) >*/
segj_1.bx[segj_1.jsno - 1] = aj / (cdh * 2.);
/*< CX( JSNO)=- AJ/(2.* SDH)* SIG >*/
segj_1.cx[segj_1.jsno - 1] = -aj / (sdh * 2.) * sig;
/*< IF( JCOX.EQ. I) GOTO 8 >*/
if (jcox == *i) {
goto L8;
}
/*< IF( JEND.EQ.1) GOTO 6 >*/
if (jend == 1) {
goto L6;
}
/*< JCOX= ICON1( JCOX) >*/
jcox = data_1.icon1[jcox - 1];
/*< GOTO 7 >*/
goto L7;
/*< 6 JCOX= ICON2( JCOX) >*/
L6:
jcox = data_1.icon2[jcox - 1];
/*< 7 IF( IABS( JCOX).EQ. I) GOTO 9 >*/
L7:
if (abs(jcox) == *i) {
goto L9;
}
/*< IF( JCOX) 1,28,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L28;
} else {
goto L2;
}
/*< 8 BX( JSNO)=- BX( JSNO) >*/
L8:
segj_1.bx[segj_1.jsno - 1] = -segj_1.bx[segj_1.jsno - 1];
/*< 9 IF( IEND.EQ.1) GOTO 11 >*/
L9:
if (iend == 1) {
goto L11;
}
/*< 10 PM=- PP >*/
L10:
pm = -pp;
/*< PP=0. >*/
pp = 0.;
/*< NJUN1= JSNO >*/
njun1 = segj_1.jsno;
/*< JCOX= ICON2( I) >*/
jcox = data_1.icon2[*i - 1];
/*< IF( JCOX.GT.10000) JCOX= I >*/
if (jcox > 10000) {
jcox = *i;
}
/*< JEND=1 >*/
jend = 1;
/*< IEND=1 >*/
iend = 1;
/*< SIG=-1. >*/
sig = -1.;
/*< IF( JCOX) 1,11,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L11;
} else {
goto L2;
}
/*< 11 NJUN2= JSNO- NJUN1 >*/
L11:
njun2 = segj_1.jsno - njun1;
/*< JSNOP= JSNO+1 >*/
jsnop = segj_1.jsno + 1;
/*< JCO( JSNOP)= I >*/
segj_1.jco[jsnop - 1] = *i;
/*< D= PI* SI( I) >*/
d = pi * data_1.si[*i - 1];
/*< SDH= SIN( D) >*/
sdh = sin(d);
/*< CDH= COS( D) >*/
cdh = cos(d);
/*< SD=2.* SDH* CDH >*/
d__1 = sdh * 2.;
sd = d__1 * cdh;
/*< CD= CDH* CDH- SDH* SDH >*/
cd = cdh * cdh - sdh * sdh;
/*< IF( D.GT.0.015) GOTO 12 >*/
if (d > .015) {
goto L12;
}
/*< OMC=4.* D* D >*/
d__1 = d * 4.;
omc = d__1 * d;
/*< OMC=((1.3888889D-3* OMC-4.1666666667D-2)* OMC+.5)* OMC >*/
omc = ((omc * .0013888889 - .041666666667) * omc + .5) * omc;
/*< GOTO 13 >*/
goto L13;
/*< 12 OMC=1.- CD >*/
L12:
omc = 1. - cd;
/*< 13 AP=1./( LOG(1./( PI* BI( I)))-.577215664D+0) >*/
L13:
ap = 1. / (log(1. / (pi * data_1.bi[*i - 1])) - .577215664);
/*< AJ= AP >*/
aj = ap;
/*< IF( NJUN1.EQ.0) GOTO 16 >*/
if (njun1 == 0) {
goto L16;
}
/*< IF( NJUN2.EQ.0) GOTO 20 >*/
if (njun2 == 0) {
goto L20;
}
/*< QP= SD*( PM* PP+ AJ* AP)+ CD*( PM* AP- PP* AJ) >*/
qp = sd * (pm * pp + aj * ap) + cd * (pm * ap - pp * aj);
/*< QM=( AP* OMC- PP* SD)/ QP >*/
qm = (ap * omc - pp * sd) / qp;
/*< QP=-( AJ* OMC+ PM* SD)/ QP >*/
qp = -(aj * omc + pm * sd) / qp;
/*< BX( JSNOP)=( AJ* QM+ AP* QP)* SDH/ SD >*/
segj_1.bx[jsnop - 1] = (aj * qm + ap * qp) * sdh / sd;
/*< CX( JSNOP)=( AJ* QM- AP* QP)* CDH/ SD >*/
segj_1.cx[jsnop - 1] = (aj * qm - ap * qp) * cdh / sd;
/*< DO 14 IEND=1, NJUN1 >*/
i__1 = njun1;
for (iend = 1; iend <= i__1; ++iend) {
/*< AX( IEND)= AX( IEND)* QM >*/
segj_1.ax[iend - 1] *= qm;
/*< BX( IEND)= BX( IEND)* QM >*/
segj_1.bx[iend - 1] *= qm;
/*< 14 CX( IEND)= CX( IEND)* QM >*/
/* L14: */
segj_1.cx[iend - 1] *= qm;
}
/*< JEND= NJUN1+1 >*/
jend = njun1 + 1;
/*< DO 15 IEND= JEND, JSNO >*/
i__1 = segj_1.jsno;
for (iend = jend; iend <= i__1; ++iend) {
/*< AX( IEND)=- AX( IEND)* QP >*/
segj_1.ax[iend - 1] = -segj_1.ax[iend - 1] * qp;
/*< BX( IEND)= BX( IEND)* QP >*/
segj_1.bx[iend - 1] *= qp;
/*< 15 CX( IEND)=- CX( IEND)* QP >*/
/* L15: */
segj_1.cx[iend - 1] = -segj_1.cx[iend - 1] * qp;
}
/*< GOTO 27 >*/
goto L27;
/*< 16 IF( NJUN2.EQ.0) GOTO 24 >*/
L16:
if (njun2 == 0) {
goto L24;
}
/*< IF( ICAP.NE.0) GOTO 17 >*/
if (*icap != 0) {
goto L17;
}
/*< XXI=0. >*/
xxi = 0.;
/*< GOTO 18 >*/
goto L18;
/*< 17 QP= PI* BI( I) >*/
L17:
qp = pi * data_1.bi[*i - 1];
/*< XXI= QP* QP >*/
xxi = qp * qp;
/*< XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qp * (1. - xxi * .5) / (1. - xxi);
/*< 18 QP=-( OMC+ XXI* SD)/( SD*( AP+ XXI* PP)+ CD*( XXI* AP- PP)) >*/
L18:
qp = -(omc + xxi * sd) / (sd * (ap + xxi * pp) + cd * (xxi * ap - pp));
/*< D= CD- XXI* SD >*/
d = cd - xxi * sd;
/*< BX( JSNOP)=( SDH+ AP* QP*( CDH- XXI* SDH))/ D >*/
d__1 = ap * qp;
segj_1.bx[jsnop - 1] = (sdh + d__1 * (cdh - xxi * sdh)) / d;
/*< CX( JSNOP)=( CDH+ AP* QP*( SDH+ XXI* CDH))/ D >*/
d__1 = ap * qp;
segj_1.cx[jsnop - 1] = (cdh + d__1 * (sdh + xxi * cdh)) / d;
/*< DO 19 IEND=1, NJUN2 >*/
i__1 = njun2;
for (iend = 1; iend <= i__1; ++iend) {
/*< AX( IEND)=- AX( IEND)* QP >*/
segj_1.ax[iend - 1] = -segj_1.ax[iend - 1] * qp;
/*< BX( IEND)= BX( IEND)* QP >*/
segj_1.bx[iend - 1] *= qp;
/*< 19 CX( IEND)=- CX( IEND)* QP >*/
/* L19: */
segj_1.cx[iend - 1] = -segj_1.cx[iend - 1] * qp;
}
/*< GOTO 27 >*/
goto L27;
/*< 20 IF( ICAP.NE.0) GOTO 21 >*/
L20:
if (*icap != 0) {
goto L21;
}
/*< XXI=0. >*/
xxi = 0.;
/*< GOTO 22 >*/
goto L22;
/*< 21 QM= PI* BI( I) >*/
L21:
qm = pi * data_1.bi[*i - 1];
/*< XXI= QM* QM >*/
xxi = qm * qm;
/*< XXI= QM*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qm * (1. - xxi * .5) / (1. - xxi);
/*< 22 QM=( OMC+ XXI* SD)/( SD*( AJ- XXI* PM)+ CD*( PM+ XXI* AJ)) >*/
L22:
qm = (omc + xxi * sd) / (sd * (aj - xxi * pm) + cd * (pm + xxi * aj));
/*< D= CD- XXI* SD >*/
d = cd - xxi * sd;
/*< BX( JSNOP)=( AJ* QM*( CDH- XXI* SDH)- SDH)/ D >*/
d__1 = aj * qm;
segj_1.bx[jsnop - 1] = (d__1 * (cdh - xxi * sdh) - sdh) / d;
/*< CX( JSNOP)=( CDH- AJ* QM*( SDH+ XXI* CDH))/ D >*/
d__1 = aj * qm;
segj_1.cx[jsnop - 1] = (cdh - d__1 * (sdh + xxi * cdh)) / d;
/*< DO 23 IEND=1, NJUN1 >*/
i__1 = njun1;
for (iend = 1; iend <= i__1; ++iend) {
/*< AX( IEND)= AX( IEND)* QM >*/
segj_1.ax[iend - 1] *= qm;
/*< BX( IEND)= BX( IEND)* QM >*/
segj_1.bx[iend - 1] *= qm;
/*< 23 CX( IEND)= CX( IEND)* QM >*/
/* L23: */
segj_1.cx[iend - 1] *= qm;
}
/*< GOTO 27 >*/
goto L27;
/*< 24 BX( JSNOP)=0. >*/
L24:
segj_1.bx[jsnop - 1] = 0.;
/*< IF( ICAP.NE.0) GOTO 25 >*/
if (*icap != 0) {
goto L25;
}
/*< XXI=0. >*/
xxi = 0.;
/*< GOTO 26 >*/
goto L26;
/*< 25 QP= PI* BI( I) >*/
L25:
qp = pi * data_1.bi[*i - 1];
/*< XXI= QP* QP >*/
xxi = qp * qp;
/*< XXI= QP*(1.-.5* XXI)/(1.- XXI) >*/
xxi = qp * (1. - xxi * .5) / (1. - xxi);
/*< 26 CX( JSNOP)=1./( CDH- XXI* SDH) >*/
L26:
segj_1.cx[jsnop - 1] = 1. / (cdh - xxi * sdh);
/*< 27 JSNO= JSNOP >*/
L27:
segj_1.jsno = jsnop;
/*< AX( JSNO)=-1. >*/
segj_1.ax[segj_1.jsno - 1] = -1.;
/*< RETURN >*/
return 0;
/*< 28 WRITE( 6,29) I >*/
L28:
s_wsfe(&io___2079);
do_fio(&c__1, (char *)&(*i), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 29 FORMAT(' TBF - SEGMENT CONNECTION ERROR FOR SEGMENT',I5) >*/
/*< END >*/
} /* tbf_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE TEST( F1R, F2R, TR, F1I, F2I, TI, DMIN) >*/
/* Subroutine */ int test_(f1r, f2r, tr, f1i, f2i, ti, dmin_)
doublereal *f1r, *f2r, *tr, *f1i, *f2i, *ti, *dmin_;
{
/* System generated locals */
doublereal d__1;
/* Local variables */
static doublereal den;
/* *** */
/* TEST FOR CONVERGENCE IN NUMERICAL INTEGRATION */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< DEN= ABS( F2R) >*/
den = abs(*f2r);
/*< TR= ABS( F2I) >*/
*tr = abs(*f2i);
/*< IF( DEN.LT. TR) DEN= TR >*/
if (den < *tr) {
den = *tr;
}
/*< IF( DEN.LT. DMIN) DEN= DMIN >*/
if (den < *dmin_) {
den = *dmin_;
}
/*< IF( DEN.LT.1.D-37) GOTO 1 >*/
if (den < 1e-37) {
goto L1;
}
/*< TR= ABS(( F1R- F2R)/ DEN) >*/
*tr = (d__1 = (*f1r - *f2r) / den, abs(d__1));
/*< TI= ABS(( F1I- F2I)/ DEN) >*/
*ti = (d__1 = (*f1i - *f2i) / den, abs(d__1));
/*< RETURN >*/
return 0;
/*< 1 TR=0. >*/
L1:
*tr = 0.;
/*< TI=0. >*/
*ti = 0.;
/*< RETURN >*/
return 0;
/*< END >*/
} /* test_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE TRIO( J) >*/
/* Subroutine */ int trio_(j)
integer *j;
{
/* Initialized data */
static integer jmax = 30;
/* Format strings */
static char fmt_10[] = "(\002 TRIO - SEGMENT CONNENTION ERROR FOR SEGM\
ENT\002,i5)";
/* Builtin functions */
integer s_wsfe(), do_fio(), e_wsfe();
/* Subroutine */ int s_stop();
/* Local variables */
static integer iend, jend, jcox;
extern /* Subroutine */ int sbf_();
/* Fortran I/O blocks */
static cilist io___2085 = { 0, 6, 0, fmt_10, 0 };
/* *** */
/* COMPUTE THE COMPONENTS OF ALL BASIS FUNCTIONS ON SEGMENT J */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< DATA JMAX/30/ >*/
/*< JSNO=0 >*/
segj_1.jsno = 0;
/*< JCOX= ICON1( J) >*/
jcox = data_1.icon1[*j - 1];
/*< IF( JCOX.GT.10000) GOTO 7 >*/
if (jcox > 10000) {
goto L7;
}
/*< JEND=-1 >*/
jend = -1;
/*< IEND=-1 >*/
iend = -1;
/*< IF( JCOX) 1,7,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L7;
} else {
goto L2;
}
/*< 1 JCOX=- JCOX >*/
L1:
jcox = -jcox;
/*< GOTO 3 >*/
goto L3;
/*< 2 JEND=- JEND >*/
L2:
jend = -jend;
/*< 3 IF( JCOX.EQ. J) GOTO 6 >*/
L3:
if (jcox == *j) {
goto L6;
}
/*< JSNO= JSNO+1 >*/
++segj_1.jsno;
/*< IF( JSNO.GE. JMAX) GOTO 9 >*/
if (segj_1.jsno >= jmax) {
goto L9;
}
/*< CALL SBF( JCOX, J, AX( JSNO), BX( JSNO), CX( JSNO)) >*/
sbf_(&jcox, j, &segj_1.ax[segj_1.jsno - 1], &segj_1.bx[segj_1.jsno - 1], &
segj_1.cx[segj_1.jsno - 1]);
/*< JCO( JSNO)= JCOX >*/
segj_1.jco[segj_1.jsno - 1] = jcox;
/*< IF( JEND.EQ.1) GOTO 4 >*/
if (jend == 1) {
goto L4;
}
/*< JCOX= ICON1( JCOX) >*/
jcox = data_1.icon1[jcox - 1];
/*< GOTO 5 >*/
goto L5;
/*< 4 JCOX= ICON2( JCOX) >*/
L4:
jcox = data_1.icon2[jcox - 1];
/*< 5 IF( JCOX) 1,9,2 >*/
L5:
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L9;
} else {
goto L2;
}
/*< 6 IF( IEND.EQ.1) GOTO 8 >*/
L6:
if (iend == 1) {
goto L8;
}
/*< 7 JCOX= ICON2( J) >*/
L7:
jcox = data_1.icon2[*j - 1];
/*< IF( JCOX.GT.10000) GOTO 8 >*/
if (jcox > 10000) {
goto L8;
}
/*< JEND=1 >*/
jend = 1;
/*< IEND=1 >*/
iend = 1;
/*< IF( JCOX) 1,8,2 >*/
if (jcox < 0) {
goto L1;
} else if (jcox == 0) {
goto L8;
} else {
goto L2;
}
/*< 8 JSNO= JSNO+1 >*/
L8:
++segj_1.jsno;
/*< CALL SBF( J, J, AX( JSNO), BX( JSNO), CX( JSNO)) >*/
sbf_(j, j, &segj_1.ax[segj_1.jsno - 1], &segj_1.bx[segj_1.jsno - 1], &
segj_1.cx[segj_1.jsno - 1]);
/*< JCO( JSNO)= J >*/
segj_1.jco[segj_1.jsno - 1] = *j;
/*< RETURN >*/
return 0;
/*< 9 WRITE( 6,10) J >*/
L9:
s_wsfe(&io___2085);
do_fio(&c__1, (char *)&(*j), (ftnlen)sizeof(integer));
e_wsfe();
/*< STOP >*/
s_stop("", 0L);
/*< 10 FORMAT(' TRIO - SEGMENT CONNENTION ERROR FOR SEGMENT',I5) >*/
/*< END >*/
} /* trio_ */
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< SUBROUTINE UNERE( XOB, YOB, ZOB) >*/
/* Subroutine */ int unere_(xob, yob, zob)
doublereal *xob, *yob, *zob;
{
/* Initialized data */
static doublereal tpi = 6.283185308;
static doublereal const_ = 4.771341188;
/* System generated locals */
doublereal d__1, d__2, d__3;
doublecomplex z__1, z__2, z__3, z__4, z__5;
/* Builtin functions */
double sqrt(), sin(), cos();
void z_sqrt(), z_div();
/* Local variables */
static doublereal t1zr, t2zr, r, xymag;
static doublecomplex q1, q2;
static doublereal r2;
static doublecomplex er;
static doublereal rt, px, py, rx, ry, zr, rz, tt1, tt2;
static doublecomplex edp;
static doublereal cth;
static doublecomplex rrh, rrv;
#define t1xj ((doublereal *)&dataj_1 + 5)
#define t1yj ((doublereal *)&dataj_1 + 6)
#define t1zj ((doublereal *)&dataj_1 + 7)
#define t2xj ((doublereal *)&dataj_1 + 1)
#define t2yj ((doublereal *)((integer *)&dataj_1 + 55))
#define t2zj ((doublereal *)((integer *)&dataj_1 + 57))
/* *** */
/* CALCULATES THE ELECTRIC FIELD DUE TO UNIT CURRENT IN THE T1 AND T2
*/
/* DIRECTIONS ON A PATCH */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< >*/
/*< >*/
/*< >*/
/* CONST=ETA/(8.*PI**2) */
/*< DATA TPI, CONST/6.283185308D+0,4.771341188D+0/ >*/
/*< ZR= ZJ >*/
zr = dataj_1.zj;
/*< T1ZR= T1ZJ >*/
t1zr = *t1zj;
/*< T2ZR= T2ZJ >*/
t2zr = *t2zj;
/*< IF( IPGND.NE.2) GOTO 1 >*/
if (dataj_1.ipgnd != 2) {
goto L1;
}
/*< ZR=- ZR >*/
zr = -zr;
/*< T1ZR=- T1ZR >*/
t1zr = -t1zr;
/*< T2ZR=- T2ZR >*/
t2zr = -t2zr;
/*< 1 RX= XOB- XJ >*/
L1:
rx = *xob - dataj_1.xj;
/*< RY= YOB- YJ >*/
ry = *yob - dataj_1.yj;
/*< RZ= ZOB- ZR >*/
rz = *zob - zr;
/*< R2= RX* RX+ RY* RY+ RZ* RZ >*/
d__1 = rx * rx + ry * ry;
r2 = d__1 + rz * rz;
/*< IF( R2.GT.1.D-20) GOTO 2 >*/
if (r2 > 1e-20) {
goto L2;
}
/*< EXK=(0.,0.) >*/
dataj_1.exk.r = 0., dataj_1.exk.i = 0.;
/*< EYK=(0.,0.) >*/
dataj_1.eyk.r = 0., dataj_1.eyk.i = 0.;
/*< EZK=(0.,0.) >*/
dataj_1.ezk.r = 0., dataj_1.ezk.i = 0.;
/*< EXS=(0.,0.) >*/
dataj_1.exs.r = 0., dataj_1.exs.i = 0.;
/*< EYS=(0.,0.) >*/
dataj_1.eys.r = 0., dataj_1.eys.i = 0.;
/*< EZS=(0.,0.) >*/
dataj_1.ezs.r = 0., dataj_1.ezs.i = 0.;
/*< RETURN >*/
return 0;
/*< 2 R= SQRT( R2) >*/
L2:
r = sqrt(r2);
/*< TT1=- TPI* R >*/
tt1 = -tpi * r;
/*< TT2= TT1* TT1 >*/
tt2 = tt1 * tt1;
/*< RT= R2* R >*/
rt = r2 * r;
/*< ER= CMPLX( SIN( TT1),- COS( TT1))*( CONST* S) >*/
d__1 = sin(tt1);
d__2 = -cos(tt1);
z__2.r = d__1, z__2.i = d__2;
d__3 = const_ * dataj_1.s;
z__1.r = d__3 * z__2.r, z__1.i = d__3 * z__2.i;
er.r = z__1.r, er.i = z__1.i;
/*< Q1= CMPLX( TT2-1., TT1)* ER/ RT >*/
d__1 = tt2 - 1.;
z__3.r = d__1, z__3.i = tt1;
z__2.r = z__3.r * er.r - z__3.i * er.i, z__2.i = z__3.r * er.i + z__3.i *
er.r;
z__1.r = z__2.r / rt, z__1.i = z__2.i / rt;
q1.r = z__1.r, q1.i = z__1.i;
/*< Q2= CMPLX(3.- TT2,-3.* TT1)* ER/( RT* R2) >*/
d__1 = 3. - tt2;
d__2 = tt1 * -3.;
z__3.r = d__1, z__3.i = d__2;
z__2.r = z__3.r * er.r - z__3.i * er.i, z__2.i = z__3.r * er.i + z__3.i *
er.r;
d__3 = rt * r2;
z__1.r = z__2.r / d__3, z__1.i = z__2.i / d__3;
q2.r = z__1.r, q2.i = z__1.i;
/*< ER= Q2*( T1XJ* RX+ T1YJ* RY+ T1ZR* RZ) >*/
d__2 = *t1xj * rx + *t1yj * ry;
d__1 = d__2 + t1zr * rz;
z__1.r = d__1 * q2.r, z__1.i = d__1 * q2.i;
er.r = z__1.r, er.i = z__1.i;
/*< EXK= Q1* T1XJ+ ER* RX >*/
z__2.r = *t1xj * q1.r, z__2.i = *t1xj * q1.i;
z__3.r = rx * er.r, z__3.i = rx * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= Q1* T1YJ+ ER* RY >*/
z__2.r = *t1yj * q1.r, z__2.i = *t1yj * q1.i;
z__3.r = ry * er.r, z__3.i = ry * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= Q1* T1ZR+ ER* RZ >*/
z__2.r = t1zr * q1.r, z__2.i = t1zr * q1.i;
z__3.r = rz * er.r, z__3.i = rz * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< ER= Q2*( T2XJ* RX+ T2YJ* RY+ T2ZR* RZ) >*/
d__2 = *t2xj * rx + *t2yj * ry;
d__1 = d__2 + t2zr * rz;
z__1.r = d__1 * q2.r, z__1.i = d__1 * q2.i;
er.r = z__1.r, er.i = z__1.i;
/*< EXS= Q1* T2XJ+ ER* RX >*/
z__2.r = *t2xj * q1.r, z__2.i = *t2xj * q1.i;
z__3.r = rx * er.r, z__3.i = rx * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= Q1* T2YJ+ ER* RY >*/
z__2.r = *t2yj * q1.r, z__2.i = *t2yj * q1.i;
z__3.r = ry * er.r, z__3.i = ry * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= Q1* T2ZR+ ER* RZ >*/
z__2.r = t2zr * q1.r, z__2.i = t2zr * q1.i;
z__3.r = rz * er.r, z__3.i = rz * er.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< IF( IPGND.EQ.1) GOTO 6 >*/
if (dataj_1.ipgnd == 1) {
goto L6;
}
/*< IF( IPERF.NE.1) GOTO 3 >*/
if (gnd_1.iperf != 1) {
goto L3;
}
/*< EXK=- EXK >*/
z__1.r = -dataj_1.exk.r, z__1.i = -dataj_1.exk.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK=- EYK >*/
z__1.r = -dataj_1.eyk.r, z__1.i = -dataj_1.eyk.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK=- EZK >*/
z__1.r = -dataj_1.ezk.r, z__1.i = -dataj_1.ezk.i;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EXS=- EXS >*/
z__1.r = -dataj_1.exs.r, z__1.i = -dataj_1.exs.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS=- EYS >*/
z__1.r = -dataj_1.eys.r, z__1.i = -dataj_1.eys.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS=- EZS >*/
z__1.r = -dataj_1.ezs.r, z__1.i = -dataj_1.ezs.i;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< GOTO 6 >*/
goto L6;
/*< 3 XYMAG= SQRT( RX* RX+ RY* RY) >*/
L3:
xymag = sqrt(rx * rx + ry * ry);
/*< IF( XYMAG.GT.1.D-6) GOTO 4 >*/
if (xymag > 1e-6) {
goto L4;
}
/*< PX=0. >*/
px = 0.;
/*< PY=0. >*/
py = 0.;
/*< CTH=1. >*/
cth = 1.;
/*< RRV=(1.,0.) >*/
rrv.r = 1., rrv.i = 0.;
/*< GOTO 5 >*/
goto L5;
/*< 4 PX=- RY/ XYMAG >*/
L4:
px = -ry / xymag;
/*< PY= RX/ XYMAG >*/
py = rx / xymag;
/*< CTH= RZ/ SQRT( XYMAG* XYMAG+ RZ* RZ) >*/
cth = rz / sqrt(xymag * xymag + rz * rz);
/*< RRV= SQRT(1.- ZRATI* ZRATI*(1.- CTH* CTH)) >*/
z__4.r = gnd_1.zrati.r * gnd_1.zrati.r - gnd_1.zrati.i * gnd_1.zrati.i,
z__4.i = gnd_1.zrati.r * gnd_1.zrati.i + gnd_1.zrati.i *
gnd_1.zrati.r;
d__1 = 1. - cth * cth;
z__3.r = d__1 * z__4.r, z__3.i = d__1 * z__4.i;
z__2.r = 1. - z__3.r, z__2.i = -z__3.i;
z_sqrt(&z__1, &z__2);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< 5 RRH= ZRATI* CTH >*/
L5:
z__1.r = cth * gnd_1.zrati.r, z__1.i = cth * gnd_1.zrati.i;
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRH=( RRH- RRV)/( RRH+ RRV) >*/
z__2.r = rrh.r - rrv.r, z__2.i = rrh.i - rrv.i;
z__3.r = rrh.r + rrv.r, z__3.i = rrh.i + rrv.i;
z_div(&z__1, &z__2, &z__3);
rrh.r = z__1.r, rrh.i = z__1.i;
/*< RRV= ZRATI* RRV >*/
z__1.r = gnd_1.zrati.r * rrv.r - gnd_1.zrati.i * rrv.i, z__1.i =
gnd_1.zrati.r * rrv.i + gnd_1.zrati.i * rrv.r;
rrv.r = z__1.r, rrv.i = z__1.i;
/*< RRV=-( CTH- RRV)/( CTH+ RRV) >*/
z__3.r = cth - rrv.r, z__3.i = -rrv.i;
z__2.r = -z__3.r, z__2.i = -z__3.i;
z__4.r = cth + rrv.r, z__4.i = rrv.i;
z_div(&z__1, &z__2, &z__4);
rrv.r = z__1.r, rrv.i = z__1.i;
/*< EDP=( EXK* PX+ EYK* PY)*( RRH- RRV) >*/
z__3.r = px * dataj_1.exk.r, z__3.i = px * dataj_1.exk.i;
z__4.r = py * dataj_1.eyk.r, z__4.i = py * dataj_1.eyk.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i +
z__2.i * z__5.r;
edp.r = z__1.r, edp.i = z__1.i;
/*< EXK= EXK* RRV+ EDP* PX >*/
z__2.r = dataj_1.exk.r * rrv.r - dataj_1.exk.i * rrv.i, z__2.i =
dataj_1.exk.r * rrv.i + dataj_1.exk.i * rrv.r;
z__3.r = px * edp.r, z__3.i = px * edp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.exk.r = z__1.r, dataj_1.exk.i = z__1.i;
/*< EYK= EYK* RRV+ EDP* PY >*/
z__2.r = dataj_1.eyk.r * rrv.r - dataj_1.eyk.i * rrv.i, z__2.i =
dataj_1.eyk.r * rrv.i + dataj_1.eyk.i * rrv.r;
z__3.r = py * edp.r, z__3.i = py * edp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.eyk.r = z__1.r, dataj_1.eyk.i = z__1.i;
/*< EZK= EZK* RRV >*/
z__1.r = dataj_1.ezk.r * rrv.r - dataj_1.ezk.i * rrv.i, z__1.i =
dataj_1.ezk.r * rrv.i + dataj_1.ezk.i * rrv.r;
dataj_1.ezk.r = z__1.r, dataj_1.ezk.i = z__1.i;
/*< EDP=( EXS* PX+ EYS* PY)*( RRH- RRV) >*/
z__3.r = px * dataj_1.exs.r, z__3.i = px * dataj_1.exs.i;
z__4.r = py * dataj_1.eys.r, z__4.i = py * dataj_1.eys.i;
z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i;
z__5.r = rrh.r - rrv.r, z__5.i = rrh.i - rrv.i;
z__1.r = z__2.r * z__5.r - z__2.i * z__5.i, z__1.i = z__2.r * z__5.i +
z__2.i * z__5.r;
edp.r = z__1.r, edp.i = z__1.i;
/*< EXS= EXS* RRV+ EDP* PX >*/
z__2.r = dataj_1.exs.r * rrv.r - dataj_1.exs.i * rrv.i, z__2.i =
dataj_1.exs.r * rrv.i + dataj_1.exs.i * rrv.r;
z__3.r = px * edp.r, z__3.i = px * edp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.exs.r = z__1.r, dataj_1.exs.i = z__1.i;
/*< EYS= EYS* RRV+ EDP* PY >*/
z__2.r = dataj_1.eys.r * rrv.r - dataj_1.eys.i * rrv.i, z__2.i =
dataj_1.eys.r * rrv.i + dataj_1.eys.i * rrv.r;
z__3.r = py * edp.r, z__3.i = py * edp.i;
z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
dataj_1.eys.r = z__1.r, dataj_1.eys.i = z__1.i;
/*< EZS= EZS* RRV >*/
z__1.r = dataj_1.ezs.r * rrv.r - dataj_1.ezs.i * rrv.i, z__1.i =
dataj_1.ezs.r * rrv.i + dataj_1.ezs.i * rrv.r;
dataj_1.ezs.r = z__1.r, dataj_1.ezs.i = z__1.i;
/*< 6 RETURN >*/
L6:
return 0;
/*< END >*/
} /* unere_ */
#undef t2zj
#undef t2yj
#undef t2xj
#undef t1zj
#undef t1yj
#undef t1xj
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< >*/
/* Subroutine */ int wire_(xw1, yw1, zw1, xw2, yw2, zw2, rad, rdel, rrad, ns,
itg)
doublereal *xw1, *yw1, *zw1, *xw2, *yw2, *zw2, *rad, *rdel, *rrad;
integer *ns, *itg;
{
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(), pow_di();
/* Local variables */
static doublereal delz, radz;
static integer i;
#define x2 ((doublereal *)&data_1 + 1800)
#define y2 ((doublereal *)&data_1 + 3000)
#define z2 ((doublereal *)&data_1 + 3600)
static doublereal rd, xd, yd, zd, xs1, ys1, zs1, xs2, ys2, zs2, fns;
static integer ist;
/* *** */
/* SUBROUTINE WIRE GENERATES SEGMENT GEOMETRY DATA FOR A STRAIGHT */
/* WIRE OF NS SEGMENTS. */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< PARAMETER ( NM=600, N2M=800, N3M=1000) >*/
/*< >*/
/*< DIMENSION X2(1), Y2(1), Z2(1) >*/
/*< EQUIVALENCE(X2(1),SI(1)),(Y2(1),ALP(1)),(Z2(1),BET(1)) >*/
/*< IST= N+1 >*/
ist = data_1.n + 1;
/*< N= N+ NS >*/
data_1.n += *ns;
/*< NP= N >*/
data_1.np = data_1.n;
/*< MP= M >*/
data_1.mp = data_1.m;
/*< IPSYM=0 >*/
data_1.ipsym = 0;
/*< IF( NS.LT.1) RETURN >*/
if (*ns < 1) {
return 0;
}
/*< XD= XW2- XW1 >*/
xd = *xw2 - *xw1;
/*< YD= YW2- YW1 >*/
yd = *yw2 - *yw1;
/*< ZD= ZW2- ZW1 >*/
zd = *zw2 - *zw1;
/*< IF( ABS( RDEL-1.).LT.1.D-6) GOTO 1 >*/
if ((d__1 = *rdel - 1., abs(d__1)) < 1e-6) {
goto L1;
}
/*< DELZ= SQRT( XD* XD+ YD* YD+ ZD* ZD) >*/
d__1 = xd * xd + yd * yd;
delz = sqrt(d__1 + zd * zd);
/*< XD= XD/ DELZ >*/
xd /= delz;
/*< YD= YD/ DELZ >*/
yd /= delz;
/*< ZD= ZD/ DELZ >*/
zd /= delz;
/*< DELZ= DELZ*(1.- RDEL)/(1.- RDEL** NS) >*/
delz = delz * (1. - *rdel) / (1. - pow_di(rdel, ns));
/*< RD= RDEL >*/
rd = *rdel;
/*< GOTO 2 >*/
goto L2;
/*< 1 FNS= NS >*/
L1:
fns = (doublereal) (*ns);
/*< XD= XD/ FNS >*/
xd /= fns;
/*< YD= YD/ FNS >*/
yd /= fns;
/*< ZD= ZD/ FNS >*/
zd /= fns;
/*< DELZ=1. >*/
delz = 1.;
/*< RD=1. >*/
rd = 1.;
/*< 2 RADZ= RAD >*/
L2:
radz = *rad;
/*< XS1= XW1 >*/
xs1 = *xw1;
/*< YS1= YW1 >*/
ys1 = *yw1;
/*< ZS1= ZW1 >*/
zs1 = *zw1;
/*< DO 3 I= IST, N >*/
i__1 = data_1.n;
for (i = ist; i <= i__1; ++i) {
/*< ITAG( I)= ITG >*/
data_1.itag[i - 1] = *itg;
/*< XS2= XS1+ XD* DELZ >*/
xs2 = xs1 + xd * delz;
/*< YS2= YS1+ YD* DELZ >*/
ys2 = ys1 + yd * delz;
/*< ZS2= ZS1+ ZD* DELZ >*/
zs2 = zs1 + zd * delz;
/*< X( I)= XS1 >*/
data_1.x[i - 1] = xs1;
/*< Y( I)= YS1 >*/
data_1.y[i - 1] = ys1;
/*< Z( I)= ZS1 >*/
data_1.z[i - 1] = zs1;
/*< X2( I)= XS2 >*/
x2[i - 1] = xs2;
/*< Y2( I)= YS2 >*/
y2[i - 1] = ys2;
/*< Z2( I)= ZS2 >*/
z2[i - 1] = zs2;
/*< BI( I)= RADZ >*/
data_1.bi[i - 1] = radz;
/*< DELZ= DELZ* RD >*/
delz *= rd;
/*< RADZ= RADZ* RRAD >*/
radz *= *rrad;
/*< XS1= XS2 >*/
xs1 = xs2;
/*< YS1= YS2 >*/
ys1 = ys2;
/*< 3 ZS1= ZS2 >*/
/* L3: */
zs1 = zs2;
}
/*< X2( N)= XW2 >*/
x2[data_1.n - 1] = *xw2;
/*< Y2( N)= YW2 >*/
y2[data_1.n - 1] = *yw2;
/*< Z2( N)= ZW2 >*/
z2[data_1.n - 1] = *zw2;
/*< RETURN >*/
return 0;
/*< END >*/
} /* wire_ */
#undef z2
#undef y2
#undef x2
/* *** */
/* DOUBLE PRECISION 6/4/85 */
/*< FUNCTION ZINT( SIGL, ROLAM) >*/
/* Double Complex */ int zint_( ret_val, sigl, rolam)
doublecomplex * ret_val;
doublereal *sigl, *rolam;
{
/* Initialized data */
static doublereal pi = 3.1415926;
static doublereal pot = 1.5707963;
static doublereal tp = 6.2831853;
static doublereal tpcmu = 2368.705;
static doublereal cmotp = 60.;
static struct {
doublereal e_1[3];
} equiv_0 = { 0., 1., 0. };
static struct {
doublereal e_1[3];
} equiv_1 = { .70710678, .70710678, 0. };
static struct {
doublereal e_1[29];
} equiv_15 = { 6e-7, 1.9e-6, -3.4e-6, 5.1e-6, -2.52e-5, 0., -9.06e-5,
-9.01e-5, 0., -9.765e-4, .0110486, -.0110485, 0., -.3926991,
1.6e-6, -3.2e-6, 1.17e-5, -2.4e-6, 3.46e-5, 3.38e-5, 5e-7,
2.452e-4, -.0013813, .0013811, -.0625001, -1e-7, .7071068,
.7071068, 0. };
/* System generated locals */
doublereal d__1, d__2, d__3, d__4;
doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10,
z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19,
z__20, z__21, z__22, z__23, z__24, z__25, z__26, z__27, z__28,
z__29, z__30, z__31, z__32, z__33, z__34, z__35, z__36, z__37,
z__38, z__39, z__40, z__41, z__42, z__43;
/* Builtin functions */
double sqrt();
void z_div(), z_exp();
/* Local variables */
static doublereal s, x, y;
#define fj ((doublecomplex *)&equiv_0)
#define cn ((doublecomplex *)&equiv_1)
#define cc1 ((doublecomplex *)&equiv_15)
#define cc2 ((doublecomplex *)&equiv_15 + 1)
#define cc3 ((doublecomplex *)&equiv_15 + 2)
#define cc4 ((doublecomplex *)&equiv_15 + 3)
#define cc5 ((doublecomplex *)&equiv_15 + 4)
#define cc6 ((doublecomplex *)&equiv_15 + 5)
#define cc7 ((doublecomplex *)&equiv_15 + 6)
#define cc8 ((doublecomplex *)&equiv_15 + 7)
#define cc9 ((doublecomplex *)&equiv_15 + 8)
static doublecomplex br1, br2;
#define cc10 ((doublecomplex *)&equiv_15 + 9)
#define cc11 ((doublecomplex *)&equiv_15 + 10)
#define cc12 ((doublecomplex *)&equiv_15 + 11)
#define cc13 ((doublecomplex *)&equiv_15 + 12)
#define cc14 ((doublecomplex *)&equiv_15 + 13)
static doublereal bei;
#define ccn ((doublereal *)&equiv_15)
static doublereal ber;
#define fjx ((doublereal *)&equiv_0)
#define cnx ((doublereal *)&equiv_1)
/* *** */
/* ZINT COMPUTES THE INTERNAL IMPEDANCE OF A CIRCULAR WIRE */
/*< IMPLICIT DOUBLE PRECISION (A-H,O-Z) >*/
/*< COMPLEX TH, PH, F, G, FJ, CN, BR1, BR2, ZINT >*/
/*< >*/
/*< DIMENSION FJX(2), CNX(2), CCN(28) >*/
/*< >*/
/*< >*/
/*< DATA CMOTP/60.00/, FJX/0.,1./, CNX/.70710678D+0,.70710678D+0/ >*/
/*< >*/
/*< >*/
/*< >*/
/*< F( D)= SQRT( POT/ D)* EXP(- CN* D+ TH(-8./ X)) >*/
/*< G( D)= EXP( CN* D+ TH(8./ X))/ SQRT( TP* D) >*/
/*< X= SQRT( TPCMU* SIGL)* ROLAM >*/
x = sqrt(tpcmu * *sigl) * *rolam;
/*< IF( X.GT.110.) GOTO 2 >*/
if (x > 110.) {
goto L2;
}
/*< IF( X.GT.8.) GOTO 1 >*/
if (x > 8.) {
goto L1;
}
/*< Y= X/8. >*/
y = x / 8.;
/*< Y= Y* Y >*/
y *= y;
/*< S= Y* Y >*/
s = y * y;
/*< >*/
ber = ((((((s * -9.01e-6 + .00122552) * s - .08349609) * s + 2.641914) *
s - 32.363456) * s + 113.77778) * s - 64.) * s + 1.;
/*< >*/
bei = ((((((s * 1.1346e-4 - .01103667) * s + .52185615) * s - 10.567658) *
s + 72.817777) * s - 113.77778) * s + 16.) * y;
/*< BR1= CMPLX( BER, BEI) >*/
z__1.r = ber, z__1.i = bei;
br1.r = z__1.r, br1.i = z__1.i;
/*< >*/
d__1 = ((((((s * -3.94e-6 + 4.5957e-4) * s - .02609253) * s + .66047849) *
s - 6.0681481) * s + 14.222222) * s - 4.) * y;
ber = d__1 * x;
/*< >*/
bei = ((((((s * 4.609e-5 - .00379386) * s + .14677204) * s - 2.3116751) *
s + 11.377778) * s - 10.666667) * s + .5) * x;
/*< BR2= CMPLX( BER, BEI) >*/
z__1.r = ber, z__1.i = bei;
br2.r = z__1.r, br2.i = z__1.i;
/*< BR1= BR1/ BR2 >*/
z_div(&z__1, &br1, &br2);
br1.r = z__1.r, br1.i = z__1.i;
/*< GOTO 3 >*/
goto L3;
/*< 1 BR2= FJ* F( X)/ PI >*/
L1:
d__1 = -8. / x;
d__2 = sqrt(pot / x);
z__7.r = -cn->r, z__7.i = -cn->i;
z__6.r = x * z__7.r, z__6.i = x * z__7.i;
z__19.r = d__1 * cc1->r, z__19.i = d__1 * cc1->i;
z__18.r = z__19.r + cc2->r, z__18.i = z__19.i + cc2->i;
z__17.r = d__1 * z__18.r, z__17.i = d__1 * z__18.i;
z__16.r = z__17.r + cc3->r, z__16.i = z__17.i + cc3->i;
z__15.r = d__1 * z__16.r, z__15.i = d__1 * z__16.i;
z__14.r = z__15.r + cc4->r, z__14.i = z__15.i + cc4->i;
z__13.r = d__1 * z__14.r, z__13.i = d__1 * z__14.i;
z__12.r = z__13.r + cc5->r, z__12.i = z__13.i + cc5->i;
z__11.r = d__1 * z__12.r, z__11.i = d__1 * z__12.i;
z__10.r = z__11.r + cc6->r, z__10.i = z__11.i + cc6->i;
z__9.r = d__1 * z__10.r, z__9.i = d__1 * z__10.i;
z__8.r = z__9.r + cc7->r, z__8.i = z__9.i + cc7->i;
z__5.r = z__6.r + z__8.r, z__5.i = z__6.i + z__8.i;
z_exp(&z__4, &z__5);
z__3.r = d__2 * z__4.r, z__3.i = d__2 * z__4.i;
z__2.r = fj->r * z__3.r - fj->i * z__3.i, z__2.i = fj->r * z__3.i + fj->i
* z__3.r;
z__1.r = z__2.r / pi, z__1.i = z__2.i / pi;
br2.r = z__1.r, br2.i = z__1.i;
/*< BR1= G( X)+ BR2 >*/
d__1 = 8. / x;
z__5.r = x * cn->r, z__5.i = x * cn->i;
z__17.r = d__1 * cc1->r, z__17.i = d__1 * cc1->i;
z__16.r = z__17.r + cc2->r, z__16.i = z__17.i + cc2->i;
z__15.r = d__1 * z__16.r, z__15.i = d__1 * z__16.i;
z__14.r = z__15.r + cc3->r, z__14.i = z__15.i + cc3->i;
z__13.r = d__1 * z__14.r, z__13.i = d__1 * z__14.i;
z__12.r = z__13.r + cc4->r, z__12.i = z__13.i + cc4->i;
z__11.r = d__1 * z__12.r, z__11.i = d__1 * z__12.i;
z__10.r = z__11.r + cc5->r, z__10.i = z__11.i + cc5->i;
z__9.r = d__1 * z__10.r, z__9.i = d__1 * z__10.i;
z__8.r = z__9.r + cc6->r, z__8.i = z__9.i + cc6->i;
z__7.r = d__1 * z__8.r, z__7.i = d__1 * z__8.i;
z__6.r = z__7.r + cc7->r, z__6.i = z__7.i + cc7->i;
z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i;
z_exp(&z__3, &z__4);
d__2 = sqrt(tp * x);
z__2.r = z__3.r / d__2, z__2.i = z__3.i / d__2;
z__1.r = z__2.r + br2.r, z__1.i = z__2.i + br2.i;
br1.r = z__1.r, br1.i = z__1.i;
/*< BR2= G( X)* PH(8./ X)- BR2* PH(-8./ X) >*/
d__1 = 8. / x;
d__2 = 8. / x;
d__3 = -8. / x;
z__6.r = x * cn->r, z__6.i = x * cn->i;
z__18.r = d__1 * cc1->r, z__18.i = d__1 * cc1->i;
z__17.r = z__18.r + cc2->r, z__17.i = z__18.i + cc2->i;
z__16.r = d__1 * z__17.r, z__16.i = d__1 * z__17.i;
z__15.r = z__16.r + cc3->r, z__15.i = z__16.i + cc3->i;
z__14.r = d__1 * z__15.r, z__14.i = d__1 * z__15.i;
z__13.r = z__14.r + cc4->r, z__13.i = z__14.i + cc4->i;
z__12.r = d__1 * z__13.r, z__12.i = d__1 * z__13.i;
z__11.r = z__12.r + cc5->r, z__11.i = z__12.i + cc5->i;
z__10.r = d__1 * z__11.r, z__10.i = d__1 * z__11.i;
z__9.r = z__10.r + cc6->r, z__9.i = z__10.i + cc6->i;
z__8.r = d__1 * z__9.r, z__8.i = d__1 * z__9.i;
z__7.r = z__8.r + cc7->r, z__7.i = z__8.i + cc7->i;
z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i;
z_exp(&z__4, &z__5);
d__4 = sqrt(tp * x);
z__3.r = z__4.r / d__4, z__3.i = z__4.i / d__4;
z__30.r = d__2 * cc8->r, z__30.i = d__2 * cc8->i;
z__29.r = z__30.r + cc9->r, z__29.i = z__30.i + cc9->i;
z__28.r = d__2 * z__29.r, z__28.i = d__2 * z__29.i;
z__27.r = z__28.r + cc10->r, z__27.i = z__28.i + cc10->i;
z__26.r = d__2 * z__27.r, z__26.i = d__2 * z__27.i;
z__25.r = z__26.r + cc11->r, z__25.i = z__26.i + cc11->i;
z__24.r = d__2 * z__25.r, z__24.i = d__2 * z__25.i;
z__23.r = z__24.r + cc12->r, z__23.i = z__24.i + cc12->i;
z__22.r = d__2 * z__23.r, z__22.i = d__2 * z__23.i;
z__21.r = z__22.r + cc13->r, z__21.i = z__22.i + cc13->i;
z__20.r = d__2 * z__21.r, z__20.i = d__2 * z__21.i;
z__19.r = z__20.r + cc14->r, z__19.i = z__20.i + cc14->i;
z__2.r = z__3.r * z__19.r - z__3.i * z__19.i, z__2.i = z__3.r * z__19.i +
z__3.i * z__19.r;
z__43.r = d__3 * cc8->r, z__43.i = d__3 * cc8->i;
z__42.r = z__43.r + cc9->r, z__42.i = z__43.i + cc9->i;
z__41.r = d__3 * z__42.r, z__41.i = d__3 * z__42.i;
z__40.r = z__41.r + cc10->r, z__40.i = z__41.i + cc10->i;
z__39.r = d__3 * z__40.r, z__39.i = d__3 * z__40.i;
z__38.r = z__39.r + cc11->r, z__38.i = z__39.i + cc11->i;
z__37.r = d__3 * z__38.r, z__37.i = d__3 * z__38.i;
z__36.r = z__37.r + cc12->r, z__36.i = z__37.i + cc12->i;
z__35.r = d__3 * z__36.r, z__35.i = d__3 * z__36.i;
z__34.r = z__35.r + cc13->r, z__34.i = z__35.i + cc13->i;
z__33.r = d__3 * z__34.r, z__33.i = d__3 * z__34.i;
z__32.r = z__33.r + cc14->r, z__32.i = z__33.i + cc14->i;
z__31.r = br2.r * z__32.r - br2.i * z__32.i, z__31.i = br2.r * z__32.i +
br2.i * z__32.r;
z__1.r = z__2.r - z__31.r, z__1.i = z__2.i - z__31.i;
br2.r = z__1.r, br2.i = z__1.i;
/*< BR1= BR1/ BR2 >*/
z_div(&z__1, &br1, &br2);
br1.r = z__1.r, br1.i = z__1.i;
/*< GOTO 3 >*/
goto L3;
/*< 2 BR1= CMPLX(.70710678D+0,-.70710678D+0) >*/
L2:
br1.r = .70710678, br1.i = -.70710678;
/*< 3 ZINT= FJ* SQRT( CMOTP/ SIGL)* BR1/ ROLAM >*/
L3:
d__1 = sqrt(cmotp / *sigl);
z__3.r = d__1 * fj->r, z__3.i = d__1 * fj->i;
z__2.r = z__3.r * br1.r - z__3.i * br1.i, z__2.i = z__3.r * br1.i +
z__3.i * br1.r;
z__1.r = z__2.r / *rolam, z__1.i = z__2.i / *rolam;
ret_val->r = z__1.r, ret_val->i = z__1.i;
/*< RETURN >*/
return ;
/*< END >*/
} /* zint_ */
#undef cnx
#undef fjx
#undef ccn
#undef cc14
#undef cc13
#undef cc12
#undef cc11
#undef cc10
#undef cc9
#undef cc8
#undef cc7
#undef cc6
#undef cc5
#undef cc4
#undef cc3
#undef cc2
#undef cc1
#undef cn
#undef fj
/*< SUBROUTINE STR0PC( STRING, STRING1) >*/
/* Subroutine */ int str0pc_(string, string1, string_len, string1_len)
char *string, *string1;
ftnlen string_len;
ftnlen string1_len;
{
/* System generated locals */
integer i__1;
/* Builtin functions */
integer i_len();
/* Local variables */
static integer i, ic;
/*< CHARACTER *(*) STRING, STRING1 >*/
/*< INTEGER*4 I, J, IC >*/
/*< DO 150, I=1, LEN( STRING) >*/
i__1 = i_len(string, string_len);
for (i = 1; i <= i__1; ++i) {
/*< IC= ICHAR( STRING( I: I)) >*/
ic = string[i - 1];
/*< IF( IC.GE.97.AND. IC.LE.122) IC= IC-32 >*/
if (ic >= 97 && ic <= 122) {
ic += -32;
}
/*< STRING1( I: I)= CHAR( IC) >*/
string1[i - 1] = ic;
/*< 150 CONTINUE >*/
/* L150: */
}
/*< RETURN >*/
return 0;
/*< END >*/
} /* str0pc_ */